C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C YXLIB Customisation Parameters
C ------------------------------
 
C Routine Names
C -------------
 
C Field Definitions: Parse Tree Attributes
C ----------------------------------------
C Note: The high-order bit in the word (bit 31 in a 32-bit machine) MUST
C       NOT BE USED, as ordinary arithmetic is used to extract some fields
 
C Attribute Table Macros
C ----------------------
 
C YXLIB Bits
C ----------
 
C YXLIB Local Record Macros
C -------------------------
C   type VARX = record
C                   su: integer;    (* Storage units for variable *)
C                   common: ^(S_COMMON) or -maxint..-1;
C                                   (* ^(common block symbol), nil (0) or
C                                      negative of equivalence class number *)
C                   comsize: integer;(* Offset in common or equiv class *)
C                   equiv: ^EQV;    (* Pointer to equivalence link *)
C                   if SYMBOL(var_arr_decl)<>0 then array: ARRAYX
C                                   (* array information stored here *)
C               end;
C
C   type ARRAYX = record
C                   elts: integer;  (* Number of elements in the array *)
C                   dims: integer;  (* Number of dimensions of the array *)
C                   limits: array [1..dims] of
C                               record LOWER,UPPER: integer end
C                 end;
 
 
C   type EQH = HEAD record          (* Equivalence head record *)
C                       common: ^(S_COMMON) or -maxint..-1;
C                       usage: set of usage_bits
C                   end;
 
C   type EQV = LINK record          (* Equivalence variable record (link) *)
C                       sudif: integer;
C                       symbol: ^(S_VAR)
C                   end;
 
C   type LPR = record
C                   glob: ^(GPU) or -^(GEX);
C                   nargs: integer;
C                   args: array [1..nargs] of packed record
C                               dtype: min_dtype..max_dtype;
C                               argument_type: atype;
C                               descendents: ^HEAD;
C                               if dtype=type_char then
C                                   min_length, max_length: integer
C                               end if
C                           end record
C              end;
 
C                                   (* Argument type definitions *)
C   type ATYPE = (scalar,arelm,array,proc,label);
C   const min_atype = scalar; max_atype = label;
 
C YXLIB Record Definition: Semi-Local
C -----------------------------------
C   type PAREC = LINK record
C                   argnum: integer; (* Argument number passed down as *)
C                   prsym: ^(S_PROC); (* Procedure passed down to *)
C                   argsym: ^symbol; (* Actual argument being passed down *)
C                   pusym: ^(S_PU); (* Associating program-unit (context) *)
C                   stmtno: integer; (* Statement number of assoc (context) *)
C                end;
 
C   type UNSAF = LINK record
C                   code: 1..5;     (* Type of unsafe reference to be checked *)
C                   argnum: integer;(* Argument number applicable *)
C                   extra: anything;(* Extra data (not used by inherit_expr) *)
C                   pusym: ^(S_PU); (* Context: associating program-unit *)
C                   stmtno: integer;(* Context: statement number *)
C                   prsym: ^(S_PROC)(* proc being called *)
C                end;
 
C YXLIB Global Record Macros
C --------------------------
C
C   type G_COM = record             Global common block record
C                   size: integer;
C                   type: (character,numeric,mixed); (* logical = numeric *)
C                   save: (saved,not_saved,only_in_main);
C                   init: integer   (* Number of times init'ed by block data *)
C                end;
 
C
C   type G_PU = record              Global program-unit record
C                   dtype: integer;
C                   chrlen: integer;
C                   culist: ^HEAD;  (* common block usage list header ptr *)
C                   nargs: integer;
C                   descend: ^HEAD; (* descendent routine list header ptr *)
C                   entrys: ^(HEAD) record ^G_ENT end;
C                   args: array [1..nargs] of gpuarg
C               end;
 
C   type G_ENT = record
C                   dtype: integer;
C                   chrlen: integer;
C                   pu: ^G_PU;
C                   nargs: integer;
C                   descend: ^HEAD; (* descendent routine list header ptr *)
C                   args: array [1..nargs] of ^guparg
C                end;
 
C type gpuarg = record
C                   dtype,chlen: integer;
C                   usage: (arg,read,update);
C                   struc: (scal,array,proc,label);
C                   size: integer;
C                   pass: ^HEAD;
C                   inh: ^HEAD(inherit)
C               end;
C type inherit = record
C                   type: (proc,expr,dupl,comm,sfa,doix,arg);
C                   ass: ^(GPU);    (* associating program-unit *)
C                   snum: integer;  (* statement number of association *)
C                   if (type=proc) then
C                       gsyptr: ^(GPU)/-^(GEX)
C                   else
C                       extra: integer (* unsafe ref extra data *)
C                   end if
 
 
C Global Descendant Routine Types
C -------------------------------
 
C Error Codes returned by YXLIB
C -----------------------------
 
 
 
 
 
 
 
 
C                                   parameter length
 
 
 
 
 
 
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C ----------------------------------------------------------------------
C
C       $ I N I _ A T T R I B   -   Initialise attribute table
C
 
        SUBROUTINE ZYXZIA
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCPAHP/USHEAD,PAHEAD,PAHEAP
        INTEGER USHEAD,PAHEAD,PAHEAP(11000)
 
        SAVE /XCPAHP/
 
        INTEGER HALLOC,LLCRHE
        EXTERNAL HINIT,HALLOC,LLCRHE
 
C Note: The attribute table uses the HEAP sub-library, and so the
C       number of the highest element in use is in SYMATR(2).
C
C The global attribute pointer is in ATRGLB, and points to a block
C whose elements contain:
C                    (1) The Program-Unit Chain
C                    (2) The Common Block Chain
C                    (3) The External References Chain
C                    (4) The ENTRY Point Chain
C These are actually zero or pointers to the HEAD record for that chain.
 
        CALL HINIT(SYMATR,69000)
        CALL HINIT(PAHEAP,11000)
        PAHEAD=LLCRHE(PAHEAP,0)
        USHEAD=LLCRHE(PAHEAP,0)
        ATRGLB=HALLOC(SYMATR,4)
        SYMATR(ATRGLB+0)=0
        SYMATR(ATRGLB+1)=0
        SYMATR(ATRGLB+2)=0
        SYMATR(ATRGLB+3)=0
 
        END
C ----------------------------------------------------------------------
C
C       $ O U T _ A T T R I B   -   Output attribute table
C
 
        SUBROUTINE ZYXOAS(IOD)
        INTEGER IOD
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER I
 
        EXTERNAL ZPTINT,PUTCH,REMARK
 
        IF (SYMATR(ATRGLB+0).EQ.0)
     +      CALL REMARK('No global attributes set')
        CALL ZPTINT(SYMATR(2),1,IOD)
        CALL PUTCH(32,IOD)
        CALL ZPTINT(ATRGLB,1,IOD)
        CALL PUTCH(10,IOD)
        DO 100 I=1,SYMATR(2)
            CALL ZPTINT(SYMATR(I),1,IOD)
            CALL PUTCH(44,IOD)
 100    CONTINUE
        CALL PUTCH(10,IOD)
 
        END
C ----------------------------------------------------------------------
C
C       $ R E A D _ A T T R I B   -   Read attribute table
C
 
        SUBROUTINE ZYXRAB(IODATR)
        INTEGER IODATR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER BUFF(134),PNTR,I,JUNK,J
 
        INTEGER ZSCTOI,GETLIN,GETCH
        EXTERNAL ZSCTOI,GETLIN,GETCH,ERROR
 
        JUNK=GETLIN(BUFF,IODATR)
        PNTR=1
        SYMATR(2)=ZSCTOI(BUFF,PNTR)
        IF (SYMATR(2).GT.69000) CALL ERROR('Too many attributes')
        ATRGLB=ZSCTOI(BUFF,PNTR)
        DO 300 I=1,SYMATR(2)
            J=0
 100        J=J+1
 200        BUFF(J)=GETCH(JUNK,IODATR)
            IF (JUNK.EQ.10) GOTO 200
            IF (JUNK.NE.44) GOTO 100
            PNTR=1
            SYMATR(I)=ZSCTOI(BUFF,PNTR)
 300    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       $ S E T _ V A L U E   -   Set the value of a tree node
C
 
        SUBROUTINE ZYXSVA(NODE,VALUE)
        INTEGER NODE,VALUE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER APTR
 
        INTEGER XZYAAB
 
        EXTERNAL ERROR
 
        IF (MOD(TREE(4,NODE),262144).NE.0)
     +      CALL ERROR('ZYXSVA: Attempt to change node value')
        APTR=XZYAAB(1)
        SYMATR(APTR)=VALUE
        TREE(4,NODE)=TREE(4,NODE)+APTR
 
        END
C ----------------------------------------------------------------------
C
C       $ D S E T _ V A L U E   -   Set the value of a tree node (DATA)
C
 
        SUBROUTINE ZYXDSV(NODE,VALUE)
        INTEGER NODE,VALUE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER APTR
 
        INTEGER XZYAAB
 
        IF (MOD(TREE(4,NODE),262144).NE.0) THEN
            APTR=MOD(TREE(4,NODE),262144)
        ELSE
            APTR=XZYAAB(1)
        END IF
        SYMATR(APTR)=VALUE
        IF (MOD(TREE(4,NODE),262144).EQ.0)
     +      TREE(4,NODE)=TREE(4,NODE)+APTR
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T _ V A L U E   -   Return value of the parse tree node
C
 
        INTEGER FUNCTION ZYXGVA(NODE)
        INTEGER NODE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER ATRPTR
 
        INTRINSIC MOD
        EXTERNAL ERROR
 
        ATRPTR=MOD(TREE(4,NODE),262144)
        IF (ATRPTR.EQ.0) CALL ERROR('ZYXGVA: No value')
        ZYXGVA=SYMATR(ATRPTR)
 
        END
C ----------------------------------------------------------------------
C
C       $ S E T _ D T Y P E   -   Set the data-type of a parse tree node
C
 
        SUBROUTINE ZYXSDT(NODE,DTYPE)
        INTEGER NODE,DTYPE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        EXTERNAL ERROR
 
        IF (TREE(4,NODE).GE.67108864)
     +      CALL ERROR('ZYXSDT: Datatype already set')
        TREE(4,NODE)=TREE(4,NODE)+DTYPE*67108864
 
        END
C ----------------------------------------------------------------------
C
C       $ D S E T _ D T Y P E   -   Set the data-type of a node (DATA)
C
 
        SUBROUTINE ZYXDST(NODE,DTYPE)
        INTEGER NODE,DTYPE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        EXTERNAL ERROR
 
        IF (TREE(4,NODE).GE.67108864) THEN
            IF (TREE(4,NODE)/67108864.NE.DTYPE)
     +          CALL ERROR('ZYXDST: Attempt to change datatype')
        ELSE
            TREE(4,NODE)=TREE(4,NODE)+DTYPE*67108864
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T _ D T Y P E   -   Return datatype of a parse tree node
C
 
        INTEGER FUNCTION ZYXGDT(NODE)
        INTEGER NODE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        EXTERNAL ERROR
 
        ZYXGDT=TREE(4,NODE)/67108864
        IF (ZYXGDT.EQ.0) CALL ERROR('ZYXGDT: No datatype')
 
        END
C ----------------------------------------------------------------------
C
C       $ S E T _ T R E E B I T   -   Set parse tree node status bit(s)
C
 
        SUBROUTINE ZYXSTB(NODE,BVAL)
        INTEGER NODE,BVAL
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        INTEGER ZIOR
        EXTERNAL ZIOR
 
        TREE(4,NODE)=ZIOR(TREE(4,NODE),BVAL)
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T _ T R E E B I T   -   Return parse tree node status bits
C
 
        INTEGER FUNCTION ZYXGTB(NODE)
        INTEGER NODE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
 
        ZYXGTB=TREE(4,NODE)
 
        END
C ----------------------------------------------------------------------
C
C       $ A D D T O _ C O M   -   Add variable to COMMON block list
C
 
        INTEGER FUNCTION ZYXATC(COMPTR,VARPTR)
        INTEGER COMPTR,VARPTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER NDIMS,PTR,VARX,ASIZE,TMP(2)
 
        INTEGER XZYAAB,ZYXSU
 
        INTEGER LLCRED,LLCRHE
        EXTERNAL LLCRED,LLINTO,LLCRHE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
C Work out how big to make the var-atr-blk if it doesn't yet exist
        IF (SYMBOL(8,VARPTR).EQ.0) THEN
            IF (SYMBOL(7,VARPTR).NE.0) THEN
                NDIMS=0
                PTR=SYMBOL(7,VARPTR)
 100            NDIMS=NDIMS+1
                PTR=NEXT(PTR)
                IF (PTR.NE.0) GOTO 100
                ASIZE=NDIMS*2+6
            ELSE
                ASIZE=4
            END IF
            SYMBOL(8,VARPTR)=XZYAAB(ASIZE)
        END IF
C Get the variable's attribute block
        VARX=SYMBOL(8,VARPTR)
C Make sure it isn't already in some other common block
        IF (SYMATR(VARX+1).NE.0) THEN
            ZYXATC=-1
            RETURN
        END IF
C Okay, say it is in this one
        SYMATR(VARX+1)=COMPTR
C If we can do it now, work out how big the variable is
        IF (SYMBOL(7,VARPTR).EQ.0 .AND.
     +      SYMBOL(5,VARPTR).GE.0) THEN
C .. ie if not an array and any character length was a simple constant
            IF (SYMBOL(5,VARPTR).EQ.0) THEN
                SYMATR(VARX)=ZYXSU(SYMBOL(4,VARPTR))
            ELSE
                SYMATR(VARX)=SYMBOL(5,VARPTR)
            END IF
        END IF
C If this is the first element then we need to create the list header
        IF (SYMBOL(7,COMPTR).EQ.0)
     +      SYMBOL(7,COMPTR)=LLCRHE(SYMATR,1)
C Now create a new element in the list of variables in that common block
        TMP(1)=VARPTR
        CALL LLINTO(SYMATR,LLCRED(SYMATR,1,TMP),
     +              SYMBOL(7,COMPTR))
C That's all folks.
        ZYXATC=-2
 
        END
C ----------------------------------------------------------------------
C
C       $ S E T _ A R D I M S   -   Set array dimension data in attr blk
C
 
        SUBROUTINE ZYXSAD(SYMPTR,NDIMS,LOWER,UPPER,ADJP,INFP)
        INTEGER SYMPTR,NDIMS,LOWER(NDIMS),UPPER(NDIMS)
        LOGICAL ADJP,INFP
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER ELTS,I,ARRAYX
 
        INTEGER XZYAAB,ZYXSU
 
        IF (SYMBOL(8,SYMPTR).EQ.0)
     +      SYMBOL(8,SYMPTR)=XZYAAB(NDIMS*2+6)
        ARRAYX=SYMBOL(8,SYMPTR)+4
        SYMATR(ARRAYX+1)=NDIMS
        IF (INFP) SYMATR(ARRAYX+1)=
     +      SYMATR(ARRAYX+1)+2048
        IF (ADJP) SYMATR(ARRAYX+1)=
     +      SYMATR(ARRAYX+1)+1024
        ELTS=1
        DO 100 I=1,NDIMS
            SYMATR(ARRAYX+I*2)=LOWER(I)
            SYMATR(ARRAYX+I*2+1)=UPPER(I)
            ELTS=ELTS*(UPPER(I)-LOWER(I)+1)
 100    CONTINUE
        IF (.NOT.(INFP.OR.ADJP)) THEN
            SYMATR(ARRAYX+0)=ELTS
C Set storage units if we know it easily
            IF (SYMBOL(5,SYMPTR).EQ.0) THEN
                SYMATR(SYMBOL(8,SYMPTR))=
     +              ELTS*ZYXSU(SYMBOL(4,SYMPTR))
            ELSE IF (SYMBOL(5,SYMPTR).GT.0) THEN
                SYMATR(SYMBOL(8,SYMPTR))=
     +              ELTS*SYMBOL(5,SYMPTR)
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T _ E L T S   -   Return number of elements in an array
C
 
        INTEGER FUNCTION ZYXGEL(SYMPTR)
        INTEGER SYMPTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        EXTERNAL ERROR
 
        IF (SYMBOL(8,SYMPTR).LE.0)
     +      CALL ERROR('ZYXGEL: Unknown 124 inapplicable')
        ZYXGEL=SYMATR(SYMBOL(8,SYMPTR)+4)
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T _ A R D I M S   -   Get array dimension information
C
 
        LOGICAL FUNCTION ZYXGAD(SYMPTR,NSUBS,LIMITS,ADJP,INFP)
        INTEGER SYMPTR,NSUBS,LIMITS(2,*)
        LOGICAL ADJP,INFP
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER I,PTR
 
        INTEGER ZIAND
        EXTERNAL ZIAND
 
        IF (SYMBOL(8,SYMPTR).EQ.0) THEN
            ZYXGAD=.FALSE.
            RETURN
        ELSE IF (SYMATR(SYMBOL(8,SYMPTR)+5).EQ.0) THEN
            ZYXGAD=.FALSE.
            RETURN
        END IF
        PTR=SYMBOL(8,SYMPTR)+4
        NSUBS=SYMATR(PTR+1)
        ADJP=ZIAND(NSUBS,1024).NE.0
        INFP=ZIAND(NSUBS,2048).NE.0
        NSUBS=MOD(NSUBS,1024)
        DO 100 I=1,NSUBS
            LIMITS(1,I)=SYMATR(PTR+I*2)
            LIMITS(2,I)=SYMATR(PTR+I*2+1)
 100    CONTINUE
        ZYXGAD=.TRUE.
 
        END
C ----------------------------------------------------------------------
C
C       $ S E T _ S F A R G S   -   Set statement function argument list
C
 
        SUBROUTINE ZYXSFA(SYMPTR,NARGS,ADTYPE,ACHLEN)
        INTEGER SYMPTR,NARGS,ADTYPE(NARGS),ACHLEN(NARGS)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER ATRPTR,I
 
        INTEGER XZYAAB
 
        EXTERNAL ERROR
 
        IF (SYMBOL(8,SYMPTR).NE.0)
     +      CALL ERROR('ZYXSFA: Already set')
        ATRPTR=XZYAAB(1+NARGS*2)
        SYMBOL(8,SYMPTR)=ATRPTR
        SYMATR(ATRPTR)=NARGS
        DO 100 I=1,NARGS
            SYMATR(ATRPTR-1+I*2)=ADTYPE(I)
            SYMATR(ATRPTR+I*2)=ACHLEN(I)
 100    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T _ S F A R G S   -   Get statement function argument list
C
 
        SUBROUTINE ZYXGFA(SYMPTR,NARGS,ADTYPE,ACHLEN)
        INTEGER SYMPTR,NARGS,ADTYPE(*),ACHLEN(*)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER ATRPTR,I
 
        EXTERNAL ERROR
 
        IF (SYMBOL(8,SYMPTR).EQ.0)
     +      CALL ERROR('ZYXGFA: No attributes found')
        ATRPTR=SYMBOL(8,SYMPTR)
        NARGS=SYMATR(ATRPTR)
        DO 100 I=1,NARGS
            ADTYPE(I)=SYMATR(ATRPTR-1+I*2)
            ACHLEN(I)=SYMATR(ATRPTR+I*2)
 100    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       $ P R O C _ A R G S E T   -   Set/check procedure arguments
C
 
        INTEGER FUNCTION ZYXPAS(NODE,INSF,STMTNO)
        INTEGER NODE,STMTNO
        LOGICAL INSF
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
        INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
 
        SAVE /XCSTRI/
 
 
        INTEGER MTYPE1
        PARAMETER (MTYPE1=5)
 
        INTEGER SYMPTR,NARGS,ABSIZE,PTR,ATRPTR,BASTYP,NT,XPTR,ARGNUM,
     +          DTYPE,ARGPTR,DCHLEN,ARGN,ARGSYM,ASTACK(160),
     +          TMP(3),I,DUPNUM,P,COUNT,MODSYL(4),MODSYU(4)
        LOGICAL CHECK,FORMAL,EXPR,INCOM,SFARG,DUPARG,ADDIT
 
        INTEGER XZYAAB,XZYTPC
        LOGICAL ZYXVOL
 
        INTEGER ZIAND,ZIOR,EQUAL,LLCRHE,LLCRED,LLFIRS,LLNEXT
        EXTERNAL ZIAND,ZIOR,EQUAL,LLCRHE,LLCRED,LLFIRS,LLNEXT,LLINTO,
     +           ERROR
 
        LOGICAL PROCP,ARRAYP
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
        PROCP(ARGN)=ZIAND(TREE(4,ARGN),8388608).NE.0
        ARRAYP(ARGN)=ZIAND(TREE(4,ARGN),4194304).NE.0
 
        DATA MODSYU/77,79,68,129/,MODSYL/109,111,100,129/
 
C Note that this routine is called for all external subprogram
C references, and so sets the "extern_arg" bit (which says that
C something is used as an actual argument (and so may be "defined")
C to an external subprogram -- this is to distinguish such usage
C from intrinsic function arguments (because intrinsic functions
C NEVER define their arguments).
 
        ZYXPAS=-1
        PTR=DOWN(NODE)
        IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
        SYMPTR=-DOWN(PTR)
        PTR=NEXT(PTR)
        NARGS=0
        ABSIZE=2
 
 100    IF (PTR.NE.0) THEN
            NARGS=NARGS+1
            IF (TREE(4,PTR)/67108864.EQ.6) THEN
                ABSIZE=ABSIZE+4
            ELSE
                ABSIZE=ABSIZE+2
            END IF
            PTR=NEXT(PTR)
            GOTO 100
        END IF
 
        CHECK=SYMBOL(7,SYMPTR).NE.0
        IF (CHECK) THEN
            ATRPTR=SYMBOL(7,SYMPTR)
            IF (SYMATR(ATRPTR+1).NE.NARGS) RETURN
        ELSE
            ATRPTR=XZYAAB(ABSIZE)
            SYMBOL(7,SYMPTR)=ATRPTR
            SYMATR(ATRPTR+1)=NARGS
        END IF
        PTR=DOWN(NODE)
        IF (NTYPE(PTR).EQ.115) PTR=NEXT(PTR)
        PTR=NEXT(PTR)
        ARGPTR=ATRPTR+2
        ARGNUM=0
 
 200    IF (PTR.NE.0) THEN
            ARGNUM=ARGNUM+1
            IF (ARGNUM.GT.160)
     +          CALL ERROR('Too many arguments in external reference')
            DTYPE=TREE(4,PTR)/67108864
            EXPR=.FALSE.
            SFARG=.FALSE.
            DUPARG=.FALSE.
            IF (PROCP(PTR)) THEN
                BASTYP=3
                ARGSYM=-DOWN(PTR)
C If procedure, get its data-type from the symbol, not the tree
                DTYPE=SYMBOL(4,ARGSYM)
C ... if supposedly "generic" intrinsic, must actually by specific
                IF (DTYPE.EQ.8) THEN
                    IF (EQUAL(STRTXT(SYMBOL(2,ARGSYM)),
     +                        MODSYL).EQ.-2 .OR.
     +                  EQUAL(STRTXT(SYMBOL(2,ARGSYM)),
     +                        MODSYU).EQ.-2) THEN
                        DTYPE = 1
                    ELSE
C ... all "generic" intrinsics are of type real when the name
C     is passed as a parameter.
                        DTYPE = 2
                    END IF
                END IF
                ASTACK(ARGNUM)=-ARGNUM
            ELSE IF (ARRAYP(PTR)) THEN
                BASTYP=2
                ARGSYM=-DOWN(PTR)
C Set extern_arg bit for array actual argument
                SYMBOL(6,ARGSYM)=
     +              ZIOR(SYMBOL(6,ARGSYM),131072)
                ASTACK(ARGNUM)=ARGSYM
            ELSE IF (DTYPE.EQ.10) THEN
                BASTYP=4
                ASTACK(ARGNUM)=-ARGNUM
            ELSE
                NT=NTYPE(PTR)
                IF (NT.EQ.108) THEN
                    BASTYP=0
                    ARGSYM=-DOWN(PTR)
C Set extern_arg bit for variable or parameter actual argument
                    SYMBOL(6,ARGSYM)=
     +                  ZIOR(SYMBOL(6,ARGSYM),131072)
                    IF (SYMBOL(1,ARGSYM).EQ.6) THEN
                        EXPR=.TRUE.
                        ASTACK(ARGNUM)=-ARGNUM
                    ELSE
                        ASTACK(ARGNUM)=ARGSYM
                    END IF
                ELSE IF (NT.EQ.104) THEN
                    BASTYP=1
                    ARGSYM=-DOWN(DOWN(PTR))
C Set extern_arg bit for array element actual argument
                    SYMBOL(6,ARGSYM)=
     +                  ZIOR(SYMBOL(6,ARGSYM),131072)
                    ASTACK(ARGNUM)=ARGSYM
                ELSE IF (NT.EQ.103) THEN
                    IF (NTYPE(DOWN(PTR)).EQ.104) THEN
                        BASTYP=1
                        ARGSYM=-DOWN(DOWN(DOWN(PTR)))
C Set extern_arg bit for array element substring actual argument
                        SYMBOL(6,ARGSYM)=
     +                      ZIOR(SYMBOL(6,ARGSYM),131072)
                        ASTACK(ARGNUM)=ARGSYM
                    ELSE
                        BASTYP=0
                        ARGSYM=-DOWN(DOWN(PTR))
C Set extern_arg bit for substring actual argument
                        SYMBOL(6,ARGSYM)=
     +                      ZIOR(SYMBOL(6,ARGSYM),131072)
                        ASTACK(ARGNUM)=ARGSYM
                    END IF
                ELSE
                    BASTYP=0
                    EXPR=.TRUE.
                    ASTACK(ARGNUM)=-ARGNUM
                END IF
            END IF
            IF (BASTYP.EQ.0 .AND. INSF) THEN
C Must check to see if this occurs in argument list
                XPTR=NODE
 300            XPTR=UP(XPTR)
                IF (NTYPE(XPTR).NE.121) GOTO 300
                XPTR=DOWN(NEXT(DOWN(XPTR)))
 400            IF (-DOWN(XPTR).NE.ARGSYM) THEN
                    XPTR=NEXT(XPTR)
                    IF (XPTR.GT.0) GOTO 400
                ELSE
                    SFARG=.TRUE.
                END IF
            END IF
            IF (CHECK) THEN
                BASTYP=XZYTPC(BASTYP,
     +                             MOD(SYMATR(ARGPTR+0),8))
                IF (BASTYP.EQ.-1) RETURN
                IF (DTYPE.NE.SYMATR(ARGPTR+0)/8+(-3))
     +              RETURN
            END IF
C Put some things passed directly as arguments onto a list
            IF (BASTYP.NE.4) THEN
C ... namely dummy arguments, actual procedure arguments, arguments in
C     common, expression arguments, statement function dummies, and
C     duplicated actuals.
                IF (EXPR .OR. SFARG) THEN
                    FORMAL=.FALSE.
                    INCOM=.FALSE.
                ELSE
                    FORMAL=ZIAND(SYMBOL(6,ARGSYM),4)
     +                     .NE.0
                    INCOM=ZIAND(SYMBOL(6,ARGSYM),
     +                          1024+524288).NE.0
C Check for duplication (except when expr/stmt fn dummy/procedure)
                    IF (BASTYP.NE.3) THEN
                        DO 500 I=1,ARGNUM-1
                            IF (ZYXVOL(ASTACK(I),ARGSYM)) THEN
                                DUPARG=.TRUE.
                                DUPNUM=I
                            END IF
 500                    CONTINUE
                    END IF
                END IF
                IF (DUPARG) THEN
C ... Duplicated arguments may overlap with formals, so do them first
                    IF (SYMATR(ARGPTR+1).EQ.0)
     +                  SYMATR(ARGPTR+1)=LLCRHE(SYMATR,0)
                    TMP(1)=2
                    TMP(2)=DUPNUM
                    TMP(3)=STMTNO
                    CALL LLINTO(SYMATR,LLCRED(SYMATR,3,TMP),
     +                          SYMATR(ARGPTR+1))
                END IF
                IF (EXPR .OR. FORMAL .OR. INCOM .OR. SFARG .OR.
     +              BASTYP.EQ.3) THEN
C ... create the list first if it hasn't been yet
                    IF (SYMATR(ARGPTR+1).EQ.0)
     +                  SYMATR(ARGPTR+1)=LLCRHE(SYMATR,0)
                    IF (FORMAL) THEN
                        TMP(1)=6
                        TMP(2)=ARGSYM
                    ELSE IF (EXPR) THEN
                        TMP(1)=1
                        TMP(2)=0
                    ELSE IF (INCOM) THEN
                        TMP(1)=3
                        TMP(2)=SYMATR(SYMBOL(8,ARGSYM)+1)
                    ELSE IF (SFARG) THEN
                        TMP(1)=4
                        TMP(2)=0
                    ELSE
                        TMP(1)=0
                        TMP(2)=ARGSYM
                    END IF
                    TMP(3)=STMTNO
C For expr: only add it if less than max (MTYPE1)
                    IF (TMP(1).EQ.1) THEN
                        COUNT=0
                        P=LLFIRS(SYMATR,SYMATR(ARGPTR+1))
                        IF (P.NE.0) THEN
 600                        IF (SYMATR(P).EQ.1)
     +                          COUNT=COUNT+1
                            P=LLNEXT(SYMATR,P)
                            IF (P.NE.0) GOTO 600
                        END IF
                        ADDIT=COUNT.LT.MTYPE1
                    ELSE
                        ADDIT=.TRUE.
                    END IF
                    IF (ADDIT)
     +                  CALL LLINTO(SYMATR,LLCRED(SYMATR,3,TMP),
     +                          SYMATR(ARGPTR+1))
                END IF
            END IF
            SYMATR(ARGPTR+0)=(DTYPE-(-3))*8+BASTYP
            IF (DTYPE.EQ.6) THEN
                DCHLEN=SYMATR(MOD(TREE(4,PTR),262144))
                IF (CHECK) THEN
                    IF (DCHLEN.LT.SYMATR(ARGPTR+2))
     +                  SYMATR(ARGPTR+2)=DCHLEN
                    IF (DCHLEN.GT.SYMATR(ARGPTR+3))
     +                  SYMATR(ARGPTR+3)=DCHLEN
                ELSE
                    SYMATR(ARGPTR+2)=DCHLEN
                    SYMATR(ARGPTR+3)=DCHLEN
                END IF
                ARGPTR=ARGPTR+4
            ELSE
                ARGPTR=ARGPTR+2
            END IF
            PTR=NEXT(PTR)
            GOTO 200
        END IF
        ZYXPAS=-2
 
        END
C ----------------------------------------------------------------------
C
C       $ S E T U _ D O I R E F   -   Set unsafe do index reference
C
 
        SUBROUTINE ZYXSUD(SYMPTR,ARGNUM,STMTNO)
        INTEGER SYMPTR,ARGNUM,STMTNO
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        INTEGER ARGPTR,I,TMP(3)
 
        INTEGER LLCRED,LLCRHE
        EXTERNAL LLCRED,LLCRHE,LLINTO
 
        ARGPTR=SYMBOL(7,SYMPTR)+2
        DO 100 I=1,ARGNUM-1
            IF (SYMATR(ARGPTR)/8+(-3).EQ.6) THEN
                ARGPTR=ARGPTR+4
            ELSE
                ARGPTR=ARGPTR+2
            END IF
 100    CONTINUE
        IF (SYMATR(ARGPTR+1).EQ.0)
     +      SYMATR(ARGPTR+1)=LLCRHE(SYMATR,0)
        TMP(1)=5
        TMP(2)=0
        TMP(3)=STMTNO
        CALL LLINTO(SYMATR,LLCRED(SYMATR,3,TMP),SYMATR(ARGPTR+1))
 
        END
C ----------------------------------------------------------------------
C
C       $ S E T _ P U A R G S   -   Set program-unit argument list
C
 
        SUBROUTINE ZYXSPA(SYMPTR,NARGS,ARGLST)
        INTEGER SYMPTR,NARGS,ARGLST(*)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        COMMON/EQLC/EQLHDR
        INTEGER EQLHDR
 
        INTEGER ATRPTR,I
 
        SAVE /EQLC/
 
        INTEGER XZYAAB
 
        EXTERNAL ERROR
 
        IF (SYMBOL(8,SYMPTR).NE.0)
     +      CALL ERROR('ZYXSPA: Argument list already set')
        SYMBOL(7,SYMPTR)=NARGS
        ATRPTR=XZYAAB(NARGS+2)
        SYMBOL(8,SYMPTR)=ATRPTR
        EQLHDR=ATRPTR+NARGS
C SYMATR(ATRPTR+NARGS+1)=^global pu block (filled in by $ADDG_PU).
        IF (NARGS.GT.0) THEN
            DO 100 I=1,NARGS
                SYMATR(ATRPTR+I-1)=ARGLST(I)
 100        CONTINUE
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       $ S C A N _ C O M   -   Pass2: Scan a common block list
C                                      and fill in all the extra bits
C
 
        INTEGER FUNCTION ZYXSCM(COMPTR,MAIN)
        INTEGER COMPTR
        LOGICAL MAIN
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER SPTR,SIZE,VPTR,HEAD
        LOGICAL SAVED
 
        INTEGER LLFIRS,LLNEXT,ZIOR,ZIAND
        EXTERNAL LLFIRS,LLNEXT,ZIOR,ZIAND,REMARK
 
        HEAD=SYMBOL(7,COMPTR)
        SYMATR(HEAD)=0
        SPTR=LLFIRS(SYMATR,HEAD)
        SAVED=SYMBOL(8,COMPTR).EQ.3
        SIZE=0
 
 100    VPTR=SYMATR(SPTR)
        IF (SYMBOL(8,VPTR).EQ.0) THEN
            CALL REMARK('ZYXSCM: NO EXTENDED ATTRIBUTE FOR ITEM')
            ZYXSCM=-67
            RETURN
        END IF
        IF (SIZE.EQ.0) THEN
C For first item in common, set the common-type
            IF (SYMBOL(4,VPTR).EQ.6) THEN
                SYMBOL(8,COMPTR)=0
            ELSE
                SYMBOL(8,COMPTR)=1
            END IF
        ELSE
C For successive items in common, adjust the common-type
            IF (SYMBOL(4,VPTR).EQ.6 .AND.
     +          SYMBOL(8,COMPTR).EQ.1 .OR.
     +          SYMBOL(4,VPTR).NE.6 .AND.
     +          SYMBOL(8,COMPTR).EQ.0)
     +          SYMBOL(8,COMPTR)=2
        END IF
C Accumulate the size of the common ...
        IF (SYMATR(SYMBOL(8,VPTR)).GT.0) THEN
C ...(a) in each variable's extended data (common-position)
            SYMATR(SYMBOL(8,VPTR)+2)=SIZE
C ...(b) for the total
            SIZE=SIZE+SYMATR(SYMBOL(8,VPTR))
        ELSE
            CALL REMARK('ZYXSCM: COMMON TOO COMPLICATED')
            ZYXSCM=-67
            RETURN
        END IF
C Accumulate all usage bits (inclusive or)
        SYMATR(HEAD)=ZIOR(SYMATR(HEAD),SYMBOL(6,VPTR))
        SPTR=LLNEXT(SYMATR,SPTR)
        IF (SPTR.NE.0) GOTO 100
 
        SYMBOL(6,COMPTR)=SIZE
        IF (MAIN) THEN
            SYMBOL(8,COMPTR)=SYMBOL(8,COMPTR)+6
        ELSE IF (SAVED) THEN
            SYMBOL(8,COMPTR)=SYMBOL(8,COMPTR)+3
        END IF
        IF (ZIAND(SYMATR(HEAD),16+32+64+
     +                         2048+128+16384+
     +                         512+65536).EQ.0) THEN
            ZYXSCM=-68
        ELSE
            ZYXSCM=-2
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       $ S E T _ S U N I T S   -   Set storage units
C
 
        SUBROUTINE ZYXSSU(SYMPTR)
        INTEGER SYMPTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER APTR
 
        INTEGER XZYAAB,ZYXGEL,ZYXSU
 
        IF (SYMBOL(8,SYMPTR).EQ.0) THEN
            APTR=XZYAAB(4)
            SYMBOL(8,SYMPTR)=APTR
        ELSE
            APTR=SYMBOL(8,SYMPTR)
        END IF
        IF (SYMATR(APTR).NE.0) RETURN
        IF (SYMBOL(5,SYMPTR).LT.0) THEN
            SYMATR(APTR)=SYMATR(MOD(TREE(4,-SYMBOL(5,SYMPTR)),
     +                              262144))
        ELSE IF (SYMBOL(5,SYMPTR).GT.0) THEN
            SYMATR(APTR)=SYMBOL(5,SYMPTR)
        ELSE
            SYMATR(APTR)=ZYXSU(SYMBOL(4,SYMPTR))
        END IF
        IF (SYMBOL(7,SYMPTR).NE.0)
     +      SYMATR(APTR)=SYMATR(APTR)*ZYXGEL(SYMPTR)
 
        END
C ----------------------------------------------------------------------
C
C       $ E V A L _ A R E L M   -   Evaluate array_element_name
C
 
        INTEGER FUNCTION ZYXEAE(NODE)
        INTEGER NODE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER PTR,SPTR,MULT,LOW,HIGH,APTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
C
C Common block and access functions for YP parse tree
C
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCTREE/ROOT,TREE,TRETOP
        INTEGER ROOT,TREE(4,46339),TRETOP
 
        SAVE /XCTREE/
C Use "JABC12" to try to avoid conflicts with ordinary variables
        INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
 
        NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
        PREV(JABC12)=(TREE(3,JABC12)/46340)
        UP(JABC12)=(TREE(1,JABC12)/46340)
        DOWN(JABC12)=TREE(2,JABC12)
        NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
        NATTR(JABC12)=TREE(4,JABC12)
 
        PTR=DOWN(NODE)
        SPTR=-DOWN(PTR)
        PTR=NEXT(PTR)
        APTR=SYMBOL(8,SPTR)+4
        IF (SYMATR(APTR+0).LT.1) THEN
            ZYXEAE=-1
            RETURN
        END IF
        ZYXEAE=0
        MULT=1
 
 100    APTR=APTR+2
        LOW=SYMATR(APTR)
        HIGH=SYMATR(APTR+1)
        ZYXEAE=ZYXEAE+
     +              MULT*(SYMATR(MOD(TREE(4,PTR),262144))-LOW)
        MULT=MULT*(HIGH-LOW+1)
        PTR=NEXT(PTR)
        IF (PTR.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       $ E Q U I V A L E N C E   -   Setup an equivalence relationship
C
C       In the following, once the variables have been loaded, these
C       conditions hold:
C           after SUDIF=...
C               loc(SYM1P)+SUDIF = loc(SYM2P)   (I)
C           after X$EQLIST_END(SYM1,SUDIF1)
C               loc(SYM1) = SUDIF1+loc(SYM1P)   (II)
C           after X$EQLIST_TOP(SYM2,SUDIF2)
C               loc(SYM2) = SUDIF2+loc(SYM2P)   (III)
C
C       From these conditions we get:
C           (a) loc(SYM1)+SUDIF-SUDIF1 = loc(SYM2P)        (by I,II)
C           (b) loc(SYM1P)+SUDIF+SUDIF2 = loc(SYM2)        (by I,III)
C           (c) loc(SYM1)+SUDIF-SUDIF1+SUDIF2 = loc(SYM2)  (by I,II,III)
C
C       From these results we can derive the storage offsets actually
C       stored in the equivalence lists.
C
 
        INTEGER FUNCTION ZYXEQV(SYM1P,SUN1,SYM2P,SUN2)
        INTEGER SYM1P,SUN1,SYM2P,SUN2
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        COMMON/EQLC/EQLHDR
        INTEGER EQLHDR
 
        INTEGER SYM1,SYM2,SUDIF,VARX1,VARX2,EQH,EQH2,EQV,EQL,EQV2,
     +          SUDIF1,SUDIF2
 
        SAVE /EQLC/
 
        INTEGER ZIAND,LLHEAD,LLPRED,LLCRHE,LLCREL,LLFIRS,LLNEXT
        EXTERNAL ZIAND,LLFOLL,LLINTO,LLHEAD,LLPRED,LLCRHE,LLCREL,LLFIRS,
     +           LLNEXT,LLDELE,LLDELH,LLPREC
 
C Check: Cannot equivalence formal parameters
        IF (ZIAND(SYMBOL(6,SYM1P),4).NE.0 .OR.
     +      ZIAND(SYMBOL(6,SYM2P),4).NE.0) THEN
            ZYXEQV=-70
            RETURN
        END IF
C If no extended data block for variables, create them
C If one variable in COMMON and the other local, add COMMON location
C  information to the local varaiable.
        IF (SYMBOL(8,SYM1P).EQ.0) THEN
            CALL ZYXSSU(SYM1P)
        ELSE IF (SYMATR(SYMBOL(8,SYM1P)+1).GT.0) THEN
            IF (SYMATR(SYMBOL(8,SYM2P)+1).EQ.0)
     +          SYMATR(SYMBOL(8,SYM2P)+1)=
     +          SYMATR(SYMBOL(8,SYM1P)+1)
        ENDIF
        IF (SYMBOL(8,SYM2P).EQ.0) THEN
            CALL ZYXSSU(SYM2P)
        ELSE IF (SYMATR(SYMBOL(8,SYM2P)+1).GT.0) THEN
            IF (SYMATR(SYMBOL(8,SYM1P)+1).EQ.0)
     +          SYMATR(SYMBOL(8,SYM1P)+1)=
     +          SYMATR(SYMBOL(8,SYM2P)+1)
        ENDIF
        SUDIF=SUN1-SUN2
        SYM1=SYM1P
        SYM2=SYM2P
        VARX1=SYMBOL(8,SYM1P)
        VARX2=SYMBOL(8,SYM2P)
        IF (SYMATR(VARX1+3).EQ.0) THEN
            IF (SYMATR(VARX2+3).EQ.0) THEN
C Neither occurs in a list, so make a list for them
C ... First create a list head and put it on the end of the list list
                EQH=LLCRHE(SYMATR,2)
                IF (SYMATR(EQLHDR).EQ.0) SYMATR(EQLHDR)=LLCRHE(SYMATR,0)
                EQL=LLCREL(SYMATR,1)
                SYMATR(EQL)=EQH
                CALL LLINTO(SYMATR,EQL,SYMATR(EQLHDR))
C ... then create eqv records and link them in
                EQV=LLCREL(SYMATR,2)
                SYMATR(VARX1+3)=EQV
                EQV2=LLCREL(SYMATR,2)
                SYMATR(VARX2+3)=EQV2
                SYMATR(EQV+1)=SYM1
                SYMATR(EQV2+1)=SYM2
                SYMATR(EQV+0)=SUDIF
                CALL LLINTO(SYMATR,EQV,EQH)
                CALL LLINTO(SYMATR,EQV2,EQH)
            ELSE
C Var 1 isn't in a list yet - put it at the front of list 2
                EQV=LLCREL(SYMATR,2)
                SYMATR(VARX1+3)=EQV
                SYMATR(EQV+1)=SYM1
                CALL XZYEQT(SYM2,SUDIF2)
                EQV2=SYMATR(SYMBOL(8,SYM2)+3)
                SYMATR(EQV+0)=SUDIF+SUDIF2
                CALL LLPREC(SYMATR,EQV,EQV2)
            END IF
        ELSE IF (SYMATR(VARX2+3).EQ.0) THEN
C Var 2 isn't in a list yet - put it at the end of list 1
            EQV=LLCREL(SYMATR,2)
            SYMATR(VARX2+3)=EQV
            SYMATR(EQV+0)=0
            SYMATR(EQV+1)=SYM2
            CALL XZYEQE(SYM1,SUDIF1)
            EQV2=SYMATR(SYMBOL(8,SYM1)+3)
            SYMATR(EQV2+0)=SUDIF-SUDIF1
            CALL LLFOLL(SYMATR,EQV,EQV2)
        ELSE
C Both are are in lists ... here comes trouble
            CALL XZYEQT(SYM2,SUDIF2)
            CALL XZYEQE(SYM1,SUDIF1)
            IF (LLHEAD(SYMATR,SYMATR(SYMBOL(8,SYM1)+3))
     +          .EQ.
     +          LLPRED(SYMATR,SYMATR(SYMBOL(8,SYM2)+3)))
     +      THEN
C Equivalence loop - it is bad or just redundant?
                SYM2=SYM2P
                CALL XZYEQE(SYM2,SUDIF2)
                IF (SUDIF.NE.SUDIF1-SUDIF2) THEN
                    ZYXEQV=-69
                    RETURN
                END IF
            ELSE
C Not a loop - join the lists
C ... Set the s.u. diff between the last of #1 & the first of #2
                EQV=SYMATR(SYMBOL(8,SYM1)+3)
                SYMATR(EQV+0)=SUDIF-SUDIF1+SUDIF2
C ... Get the head pointers
                EQH=LLHEAD(SYMATR,EQV)
                EQH2=LLPRED(SYMATR,
     +                      SYMATR(SYMBOL(8,SYM2)+3))
C ... Loop: move first element from #2 to the end of #1
 100            EQV=LLFIRS(SYMATR,EQH2)
                IF (EQV.GT.0) THEN
                    CALL LLINTO(SYMATR,EQV,EQH)
                    GOTO 100
                END IF
C ... Find the list list entry for list #2 ... and delete it
                EQL=SYMATR(EQLHDR)
 200            EQL=LLNEXT(SYMATR,EQL)
                IF (SYMATR(EQL).NE.EQH2) GOTO 200
                CALL LLDELE(SYMATR,EQL)
C ... Delete list header for #2
                CALL LLDELH(SYMATR,EQH2)
            END IF
        END IF
        ZYXEQV=-2
 
        END
C ----------------------------------------------------------------------
C
C       X $ E Q L I S T _ E N D   -   Move to the end of an EQUIV list
C
 
        SUBROUTINE XZYEQE(SYM,SUDIF)
        INTEGER SYM,SUDIF
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        INTEGER TMP,EQV
 
        INTEGER LLNEXT
        EXTERNAL LLNEXT
 
        SUDIF=0
        EQV=SYMATR(SYMBOL(8,SYM)+3)
 
 100    TMP=LLNEXT(SYMATR,EQV)
        IF (TMP.GT.0) THEN
            SUDIF=SUDIF+SYMATR(EQV+0)
            EQV=TMP
            GOTO 100
        END IF
        SYM=SYMATR(EQV+1)
 
        END
C ----------------------------------------------------------------------
C
C       X $ E Q L I S T _ T O P   -   Move to the top of an EQUIV list
C
 
        SUBROUTINE XZYEQT(SYM,SUDIF)
        INTEGER SYM,SUDIF
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        INTEGER TMP,EQV
 
        INTEGER LLPREV
        EXTERNAL LLPREV
 
        SUDIF=0
        EQV=SYMATR(SYMBOL(8,SYM)+3)
 
 100    TMP=LLPREV(SYMATR,EQV)
        IF (TMP.GT.0) THEN
            EQV=TMP
            SUDIF=SUDIF-SYMATR(EQV+0)
            GOTO 100
        END IF
        SYM=SYMATR(EQV+1)
 
        END
C ----------------------------------------------------------------------
C
C       $ C H E C K _ E Q U I V S   -   Check Equivalences
C
C       Also propagate usage bits into the COMMON header
C
C       Also propogate storage allocation information into VARX records
C
 
        SUBROUTINE ZYXCEQ(ERRSYM)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        COMMON/EQLC/EQLHDR
        INTEGER EQLHDR
 
        INTEGER COMPTR,MINSU,MAXSU,EQLPTR,EQIPTR,EQV,SUNUM,COMOFF,USAGE,
     +          EQH,CLASS
 
        SAVE /EQLC/
 
        INTEGER ZIAND,ZIOR,LLFIRS,LLNEXT
        EXTERNAL ZIAND,ZIOR,LLFIRS,LLNEXT
        INTEGER COMSTK,COMUST,COMUSP
        PARAMETER (COMSTK=20)
        INTEGER COMUNU(COMSTK)
 
        IF (SYMATR(EQLHDR).EQ.0) RETURN
        EQLPTR=LLFIRS(SYMATR,SYMATR(EQLHDR))
        CLASS=1
        COMUST=0
 
C ... Processing an equivalence list
 100    CONTINUE
        EQH=SYMATR(EQLPTR)
        EQV=LLFIRS(SYMATR,EQH)
        COMPTR=0
        MINSU=1
        MAXSU=1
        SUNUM=1
        USAGE=0
 
C ... Processing an item on an equivalence list
 200    EQIPTR=SYMATR(EQV+1)
        USAGE=ZIOR(USAGE,SYMBOL(6,EQIPTR))
        IF (ZIAND(SYMBOL(6,EQIPTR),1024).NE.0) THEN
            IF (COMPTR.EQ.0) THEN
                COMPTR=SYMATR(SYMBOL(8,EQIPTR)+1)
                COMOFF=SYMATR(SYMBOL(8,EQIPTR)+2)-SUNUM
            ELSE
                IF (COMPTR.NE.
     +              SYMATR(SYMBOL(8,EQIPTR)+1)) THEN
                    CALL ERRSYM('Different COMMONs EQUIVALENCEd - ',
     +                          COMPTR,-1)
                ELSE IF (COMOFF+SUNUM.NE.
     +                   SYMATR(SYMBOL(8,EQIPTR)+2))
     +          THEN
                    CALL ERRSYM('EQUIVALENCE conflicts with COMMON ',
     +                          COMPTR,-1)
                END IF
            END IF
        END IF
        MAXSU=MAX(MAXSU,SUNUM+SYMATR(SYMBOL(8,EQIPTR)))
        SUNUM=SUNUM+SYMATR(EQV+0)
        IF (SUNUM.LT.MINSU) MINSU=SUNUM
 
C ... process next item on an equivalence list
        EQV=LLNEXT(SYMATR,EQV)
        IF (EQV.GT.0) GOTO 200
 
C ... processed all items on list - check results
        SYMATR(EQH+0)=COMPTR
        SYMATR(EQH+1)=USAGE
        IF (COMPTR.NE.0) THEN
C ... EQUIVALENCE involves COMMON - more to do and check
            SYMATR(SYMBOL(7,COMPTR))=
     +          ZIOR(SYMATR(SYMBOL(7,COMPTR)),USAGE)
            IF (ZIAND(SYMATR(SYMBOL(7,COMPTR)),
     +                16+32+64+2048+
     +                128+16384+65536).EQ.0) THEN
C ... COMMON is unused, put on stack and output error if not
C     already stacked
                DO 250 COMUSP=1,COMUST
                    IF (COMUNU(COMUSP).EQ.COMPTR) GOTO 260
 250            CONTINUE
                IF (COMUST.LT.COMSTK) COMUST=COMUST+1
                COMUNU(COMUST)=COMPTR
                CALL ERRSYM('Unused common block - ',COMPTR,-1002)
 260            CONTINUE
            ENDIF
            IF (COMOFF+MINSU.LT.0) THEN
                CALL ERRSYM('Backward extension of COMMON ',
     +                      COMPTR,-1)
            ELSE
C Check for COMMON being made larger via this EQUIVALENCE
                IF (COMOFF+MAXSU.GT.SYMBOL(6,COMPTR))
     +              SYMBOL(6,COMPTR)=COMOFF+MAXSU
C ... Run through the equivalence list again, setting the common values
                EQV=LLFIRS(SYMATR,EQH)
                SUNUM=1
 300            EQIPTR=SYMATR(EQV+1)
C ... Mark this variable as being stored in common and say where
                SYMBOL(6,EQIPTR)=
     +              ZIOR(SYMBOL(6,EQIPTR),524288)
                SYMATR(SYMBOL(8,EQIPTR)+2)=
     +              COMOFF+SUNUM
                SUNUM=SUNUM+SYMATR(EQV+0)
                EQV=LLNEXT(SYMATR,EQV)
                IF (EQV.NE.0) GOTO 300
            END IF
        ELSE
C ... Local equivalence class - set storage allocation info in VARX rcd
            EQV=LLFIRS(SYMATR,EQH)
            SUNUM=1
 400        EQIPTR=SYMATR(EQV+1)
            SYMATR(SYMBOL(8,EQIPTR)+1)=-CLASS
            SYMATR(SYMBOL(8,EQIPTR)+2)=SUNUM-MINSU
            SUNUM=SUNUM+SYMATR(EQV+0)
            EQV=LLNEXT(SYMATR,EQV)
            IF (EQV.NE.0) GOTO 400
            CLASS=CLASS+1
        END IF
 
C ... process next equivalence list
        EQLPTR=LLNEXT(SYMATR,EQLPTR)
        IF (EQLPTR.GT.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T _ L O C A T I O N   -   Return storage allocation info
C
 
        SUBROUTINE ZYXGVL(VARPTR,PLACE,OFFSET)
        INTEGER VARPTR,PLACE,OFFSET
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        PLACE=SYMATR(SYMBOL(8,VARPTR)+1)
        OFFSET=SYMATR(SYMBOL(8,VARPTR)+2)
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T _ E Q L I S T   -   Get an equivalence list header
C
 
        SUBROUTINE ZYXGEQ(PUSYM,EQLIST,EQHCOM,EQHUSE,EQVPTR)
        INTEGER PUSYM,EQLIST,EQHCOM,EQHUSE,EQVPTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER LLNEXT,LLFIRS
        EXTERNAL LLNEXT,LLFIRS,ERROR
 
        IF (EQLIST.EQ.0) THEN
C If we want the first equivalence list for a program-unit
            IF (SYMBOL(8,PUSYM).LE.0) THEN
C Make sure we have an extended data block to get it from
                CALL ERROR('ZYXGEQ: No PUX record')
            ELSE IF (
     +        SYMATR(SYMBOL(8,PUSYM)+SYMBOL(7,PUSYM)).EQ.0)
     +      THEN
C If there are no equivalence lists then say so
                EQLIST=-1
            ELSE
C Otherwise find the first
                EQLIST=LLFIRS(SYMATR,
     +            SYMATR(SYMBOL(8,PUSYM)+SYMBOL(7,PUSYM)))
            END IF
        END IF
        IF (EQLIST.GT.0) THEN
C Fetch the data for the current equivalence list
            EQHCOM=SYMATR(SYMATR(EQLIST)+0)
            EQHUSE=SYMATR(SYMATR(EQLIST)+1)
            EQVPTR=LLFIRS(SYMATR,SYMATR(EQLIST))
C And then advance the eqlist pointer
            EQLIST=LLNEXT(SYMATR,EQLIST)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T _ E Q V D A T A   -   Get equivalence data
C
 
        SUBROUTINE ZYXGED(EQVPTR,VARPTR,OFFSET)
        INTEGER EQVPTR,VARPTR,OFFSET
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER LLNEXT
        EXTERNAL LLNEXT,ERROR
 
        IF (EQVPTR.LE.0) CALL ERROR('ZYXGED: Invalid EQV pointer')
        VARPTR=SYMATR(EQVPTR+1)
        OFFSET=SYMATR(EQVPTR+0)
        EQVPTR=LLNEXT(SYMATR,EQVPTR)
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T _ E Q U I V _ H E A D   -   Get equivalence head
C                                           (return equivalence list
C                                            data from a var in it).
C
 
        SUBROUTINE ZYXGEH(VARPTR,EQHCOM,EQHUSE,EQVPTR)
        INTEGER VARPTR,EQHCOM,EQHUSE,EQVPTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        INTEGER EQV,EQH
 
        INTEGER LLHEAD,LLFIRS
        EXTERNAL LLHEAD,LLFIRS,ERROR
 
C Get pointer to eqv record
        EQV=SYMATR(SYMBOL(8,VARPTR)+3)
C Make sure there is one
        IF (EQV.EQ.0) CALL ERROR('ZYXGEH: Not in equiv..')
C Okay, get pointer to owning eqh record
        EQH=LLHEAD(SYMATR,EQV)
C Return data from eqh record
        EQHCOM=SYMATR(EQH+0)
        EQHUSE=SYMATR(EQH+1)
C Return pointer to first eqv record in the list
        EQVPTR=LLFIRS(SYMATR,EQH)
 
        END
C ----------------------------------------------------------------------
C
C       $ E Q C L A S S _ S I Z E   -   Return size of an equivalence
C                                       class, in char storage units
C
 
        INTEGER FUNCTION ZYXECS(PUSYM,CLASS)
        INTEGER PUSYM,CLASS
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER EQLIST,EQH,COUNT,MINSU,MAXSU,EQV,EQIPTR,SUNUM
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT,ERROR
 
        IF (SYMBOL(8,PUSYM).LE.0)
     +      CALL ERROR('ZYXECS: No extended PU block')
        IF (SYMATR(SYMBOL(8,PUSYM)+SYMBOL(7,PUSYM)).EQ.0)
     +      CALL ERROR('ZYXECS: No equivalence lists found')
        EQLIST=LLFIRS(SYMATR,
     +      SYMATR(SYMBOL(8,PUSYM)+SYMBOL(7,PUSYM)))
        COUNT=0
 
 100    EQH=SYMATR(EQLIST)
        IF (SYMATR(EQH+0).EQ.0) COUNT=COUNT+1
        IF (COUNT.LT.CLASS) THEN
            EQLIST=LLNEXT(SYMATR,EQLIST)
            IF (EQLIST.NE.0) GOTO 100
            CALL ERROR('ZYXECS: Invalid class numb'//'er')
        END IF
 
        EQV=LLFIRS(SYMATR,EQH)
        MINSU=1
        MAXSU=1
        SUNUM=1
 200    EQIPTR=SYMATR(EQV+1)
        MAXSU=MAX(MAXSU,MINSU+SYMATR(SYMBOL(8,EQIPTR)+0))
        SUNUM=SUNUM+SYMATR(EQV+0)
        MINSU=MIN(MINSU,SUNUM)
        EQV=LLNEXT(SYMATR,EQV)
        IF (EQV.GT.0) GOTO 200
 
        ZYXECS=MAXSU-MINSU
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T _ C O M V A R   -   Return first/next variable in COMMON
C
 
        SUBROUTINE ZYXGCV(COMPTR,VARPTR)
        INTEGER COMPTR,VARPTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT
 
        IF (COMPTR.GT.0)
     +      COMPTR=-LLFIRS(SYMATR,SYMBOL(7,COMPTR))
        VARPTR=SYMATR(-COMPTR)
        COMPTR=-LLNEXT(SYMATR,-COMPTR)
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T _ C O M _ U S E   -   Return common usage
C
 
        INTEGER FUNCTION ZYXCUS(COMPTR)
        INTEGER COMPTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        ZYXCUS=SYMATR(SYMBOL(7,COMPTR))
 
        END
C ----------------------------------------------------------------------
C
C       $ V A R S _ O V E R L A P   -   Whether variables overlap
C
 
        LOGICAL FUNCTION ZYXVOL(VARPT1,VARPT2)
        INTEGER VARPT1,VARPT2
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER VARX1,VARX2
 
        EXTERNAL ERROR
 
        IF (VARPT1.EQ.VARPT2) THEN
C Same variable
            ZYXVOL=.TRUE.
        ELSE IF (VARPT1.LT.1 .OR. VARPT2.LT.1) THEN
C Negative numbers are for expression actual arguments and the like
C -- strangely enough, these never overlap!
            ZYXVOL=.FALSE.
        ELSE IF (SYMBOL(8,VARPT1).EQ.0 .OR.
     +           SYMBOL(8,VARPT2).EQ.0) THEN
C No extended data block - cannot happen!
            CALL ERROR('ZYXVOL: Missing VARX record')
        ELSE
            VARX1=SYMBOL(8,VARPT1)
            VARX2=SYMBOL(8,VARPT2)
            IF (SYMATR(VARX1+1).EQ.0 .OR.
     +          SYMATR(VARX1+1).NE.SYMATR(VARX2+1))
     +      THEN
C Local non-equivalenced variables cannot overlap, and
C others must be in the same common block or equivalence class
C (dummy variables look like unequivalenced locals, so that's ok)
                ZYXVOL=.FALSE.
            ELSE IF (
     +          SYMATR(VARX1+2)+SYMATR(VARX1+0).LE.
     +          SYMATR(VARX2+2) .OR.
     +          SYMATR(VARX2+2)+SYMATR(VARX2+0).LE.
     +          SYMATR(VARX1+2)) THEN
C They are in the same place - but they still don't overlap if the top
C of the first is less than the bottom of the second or vice versa
                ZYXVOL=.FALSE.
            ELSE
C Nope - they must overlap then
                ZYXVOL=.TRUE.
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       $ S U   -   Return storage units per datatype
C
 
        INTEGER FUNCTION ZYXSU(DTYPE)
        INTEGER DTYPE
 
        INTEGER DPSIZE,CMSIZE,DCMSIZ,R16SIZ,I2SIZE,L1SIZE,L2SIZE
        PARAMETER (DPSIZE=4*2,CMSIZE=DPSIZE,DCMSIZ=CMSIZE*2,
     +             R16SIZ=4*4,I2SIZE=4/2,
     +             L1SIZE=4/4,L2SIZE=4/2)
 
        INTEGER BSIZE(15)
 
        SAVE BSIZE
 
        DATA BSIZE(6)/1/,
     +       BSIZE(1)/4/,
     +       BSIZE(2)/4/,
     +       BSIZE(5)/DPSIZE/,
     +       BSIZE(4)/CMSIZE/,
     +       BSIZE(3)/4/,
     +       BSIZE(7)/DCMSIZ/,
     +       BSIZE(12)/L1SIZE/,
     +       BSIZE(13)/L2SIZE/,
     +       BSIZE(14)/I2SIZE/,
     +       BSIZE(15)/R16SIZ/
 
        ZYXSU=BSIZE(DTYPE)
 
        END
C ----------------------------------------------------------------------
C
C       $ A D D G _ P U   -   Add global symbol for program unit
C
 
        INTEGER FUNCTION ZYXAPU(SYMPTR)
        INTEGER SYMPTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
        INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
 
        SAVE /XCSTRI/
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER NARGS,PUPTR,ARGPTR,I,NAMLEN,PUDATA
 
        INTEGER ZYXGVA
 
        INTEGER ZIAND,EQUAL,LENGTH,LLCRHE,LLFIRS,LLNEXT,LLCREL,ZYCADT
        EXTERNAL ZIAND,EQUAL,LENGTH,SCOPY,LLCRHE,LLFIRS,LLNEXT,LLCREL,
     +           LLINTO,ZYCADT
 
        IF (SYMATR(ATRGLB+0).EQ.0)
     +      SYMATR(ATRGLB+0)=LLCRHE(SYMATR,0)
        PUPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+0))
 100    IF (PUPTR.NE.0) THEN
            IF (EQUAL(STRTXT(SYMBOL(2,SYMPTR)),
     +                SYMATR(PUPTR)).EQ.-2) THEN
                ZYXAPU=-1
                RETURN
            END IF
            PUPTR=LLNEXT(SYMATR,PUPTR)
            GOTO 100
        END IF
        IF (SYMATR(ATRGLB+3).NE.0)
     +      PUPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+3))
 200    IF (PUPTR.NE.0) THEN
            IF (EQUAL(STRTXT(SYMBOL(2,SYMPTR)),
     +                SYMATR(PUPTR)).EQ.-2) THEN
                ZYXAPU=-1
                RETURN
            END IF
            PUPTR=LLNEXT(SYMATR,PUPTR)
            GOTO 200
        END IF
        NARGS=SYMBOL(7,SYMPTR)
        NAMLEN=LENGTH(STRTXT(SYMBOL(2,SYMPTR)))
C Create the global pu data block & link it to the global pu list
        PUPTR=LLCREL(SYMATR,NAMLEN+7+NARGS*7)
        CALL LLINTO(SYMATR,PUPTR,SYMATR(ATRGLB+0))
C Store a pointer to the global pu block in the local pu block
        SYMATR(SYMBOL(8,SYMPTR)+NARGS+1)=PUPTR
        PUDATA=PUPTR+NAMLEN
        CALL SCOPY(STRTXT,SYMBOL(2,SYMPTR),SYMATR,PUPTR)
C Store canonicalised data type in global pu block
        IF (SYMBOL(4,SYMPTR).NE.6) THEN
            SYMATR(PUDATA+1)=
     +          ZYCADT(SYMBOL(4,SYMPTR),
     +                 SYMBOL(5,SYMPTR))
            SYMATR(PUDATA+2)=0
        ELSE
            SYMATR(PUDATA+1)=6
            IF (SYMBOL(5,SYMPTR).LT.0) THEN
                SYMATR(PUDATA+2)=
     +              ZYXGVA(-SYMBOL(5,SYMPTR))
            ELSE IF (SYMBOL(5,SYMPTR).GT.0) THEN
                SYMATR(PUDATA+2)=SYMBOL(5,SYMPTR)
            ELSE
                SYMATR(PUDATA+2)=1
            END IF
        END IF
        SYMATR(PUDATA+4)=NARGS
        SYMATR(PUDATA+5)=0
        SYMATR(PUDATA+3)=0
        SYMATR(PUDATA+6)=0
        PUDATA=PUDATA+7
        DO 400 I=0,NARGS-1
            ARGPTR=SYMATR(SYMBOL(8,SYMPTR)+I)
            IF (ARGPTR.LT.1) THEN
C "label" dummy arguments don't have symbols attached...
                SYMATR(PUDATA+0)=10
                SYMATR(PUDATA+3)=3
                GOTO 300
            END IF
            IF (SYMBOL(4,ARGPTR).NE.6) THEN
                SYMATR(PUDATA+0)=
     +              ZYCADT(SYMBOL(4,ARGPTR),
     +                     SYMBOL(5,ARGPTR))
                SYMATR(PUDATA+1)=0
            ELSE
                SYMATR(PUDATA+0)=6
                IF (SYMBOL(5,ARGPTR).LT.0) THEN
                    SYMATR(PUDATA+1)=
     +                  ZYXGVA(-SYMBOL(5,ARGPTR))
                ELSE IF (SYMBOL(5,ARGPTR).EQ.0) THEN
                    SYMATR(PUDATA+1)=1
                ELSE
                    SYMATR(PUDATA+1)=
     +                  SYMBOL(5,ARGPTR)
                END IF
            END IF
C Argument usage
            IF (ZIAND(SYMBOL(6,ARGPTR),
     +          16+32+64+65536).EQ.0)
     +      THEN
                IF (ZIAND(SYMBOL(6,ARGPTR),131072).EQ.0)
     +          THEN
                    SYMATR(PUDATA+2)=1
                ELSE
                    SYMATR(PUDATA+2)=0
                END IF
            ELSE
                SYMATR(PUDATA+2)=2
            END IF
C Argument structure
            IF (SYMBOL(1,ARGPTR).EQ.7) THEN
                SYMATR(PUDATA+3)=2
            ELSE IF (SYMBOL(7,ARGPTR).NE.0) THEN
                SYMATR(PUDATA+3)=1
            ELSE
                SYMATR(PUDATA+3)=0
            END IF
C Argument size: (only for variables/arrays) (0=inf/adj)
            IF (SYMBOL(1,ARGPTR).EQ.5) THEN
                SYMATR(PUDATA+4)=
     +              SYMATR(SYMBOL(8,ARGPTR))
            ELSE
                SYMATR(PUDATA+4)=0
            END IF
            SYMATR(PUDATA+5)=0
            SYMATR(PUDATA+6)=0
 300        PUDATA=PUDATA+7
 400    CONTINUE
        ZYXAPU=-2
 
        END
C ----------------------------------------------------------------------
C
C       $ A D D G _ E N T R Y   -   Add global symbol for ENTRY point
C
 
        INTEGER FUNCTION ZYXAEN(SYMPTR,PUSYM)
        INTEGER SYMPTR,PUSYM
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
        INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
 
        SAVE /XCSTRI/
 
 
        INTEGER PTR,PUGLOB,NAMLEN,PTR2,PTR3,I,ARGPTR
 
        INTEGER XZYAAB
 
        INTEGER LLCRHE,EQUAL,LLNEXT,LENGTH,ZYCADT,LLCREL,ZIAND,LLFIRS,
     +          ZYXGVA
        EXTERNAL LLCRHE,EQUAL,LLNEXT,LENGTH,ZYCADT,LLCREL,ZIAND,LLFIRS,
     +           ZYXGVA,LLINTO,SCOPY
 
C Duplicating an existing p.u. name?
        PTR=LLFIRS(SYMATR,SYMATR(ATRGLB+0))
 100    IF (PTR.NE.0) THEN
            IF (EQUAL(STRTXT(SYMBOL(2,SYMPTR)),
     +                SYMATR(PTR)).EQ.-2) THEN
                ZYXAEN=-1
                RETURN
            END IF
            PTR=LLNEXT(SYMATR,PTR)
            GOTO 100
        END IF
C No, duplicating an existing entry point name?
        IF (SYMATR(ATRGLB+3).NE.0)
     +      PTR=LLFIRS(SYMATR,SYMATR(ATRGLB+3))
 200    IF (PTR.NE.0) THEN
            IF (EQUAL(STRTXT(SYMBOL(2,SYMPTR)),
     +                SYMATR(PTR)).EQ.-2) THEN
                ZYXAEN=-1
                RETURN
            END IF
            PTR=LLNEXT(SYMATR,PTR)
            GOTO 200
        END IF
C No, then we add it.
C First make sure we have an entry point list.
        IF (SYMATR(ATRGLB+3).EQ.0)
     +      SYMATR(ATRGLB+3)=LLCRHE(SYMATR,0)
C Secondly, skip past name in parent program-unit's record
        PUGLOB=SYMATR(SYMBOL(8,PUSYM)+SYMBOL(7,PUSYM)+1)
 300    IF (SYMATR(PUGLOB).NE.129) THEN
            PUGLOB=PUGLOB+1
            GOTO 300
        END IF
C And create its descendent entry point list if necessary.
        IF (SYMATR(PUGLOB+6).EQ.0)
     +      SYMATR(PUGLOB+6)=LLCRHE(SYMATR,0)
        NAMLEN=LENGTH(STRTXT(SYMBOL(2,SYMPTR)))
C Create the global entry point block & link it to the global en list
        PTR=LLCREL(SYMATR,NAMLEN+6+SYMBOL(7,SYMPTR))
        CALL LLINTO(SYMATR,PTR,SYMATR(ATRGLB+3))
C Store a pointer to the global en block in the local en block
        SYMATR(SYMBOL(8,SYMPTR)+
     +         SYMBOL(7,SYMPTR)+1)=PTR
C Copy the name in
        CALL SCOPY(STRTXT,SYMBOL(2,SYMPTR),SYMATR,PTR)
C Create an element in the pu blocks entry list pointing to this
        PTR2=LLCREL(SYMATR,1)
        SYMATR(PTR2)=PTR
        CALL LLINTO(SYMATR,PTR2,SYMATR(PUGLOB+6))
C Now fill in the data ...
        PTR=PTR+NAMLEN
C Store canonicalised data type in global en block
        IF (SYMBOL(4,SYMPTR).NE.6) THEN
            SYMATR(PTR+1)=
     +          ZYCADT(SYMBOL(4,SYMPTR),
     +                 SYMBOL(5,SYMPTR))
            SYMATR(PTR+2)=0
        ELSE
            SYMATR(PTR+1)=6
            IF (SYMBOL(5,SYMPTR).LT.0) THEN
                SYMATR(PTR+2)=
     +              ZYXGVA(-SYMBOL(5,SYMPTR))
            ELSE IF (SYMBOL(5,SYMPTR).GT.0) THEN
                SYMATR(PTR+2)=SYMBOL(5,SYMPTR)
            ELSE
                SYMATR(PTR+2)=1
            END IF
        END IF
C Store pointer to parent p.u.
        SYMATR(PTR+3)=
     +      SYMATR(SYMBOL(8,PUSYM)+SYMBOL(7,PUSYM)+1)
C Store number of arguments
        SYMATR(PTR+4)=SYMBOL(7,SYMPTR)
C Now comes the difficult bit: storing the argument data
        DO 600 I=0,SYMBOL(7,SYMPTR)-1
C ... first see if we can find the argument amongst the p.u. args
            PTR3=PUGLOB+7
            DO 400 PTR2=SYMBOL(8,PUSYM),
     +                  SYMBOL(8,PUSYM)+SYMBOL(7,PUSYM)-1
                IF (SYMATR(PTR2).EQ.SYMATR(SYMBOL(8,SYMPTR)+I))
     +          THEN
                    SYMATR(PTR+6+I)=PTR3
                    GOTO 500
                END IF
                PTR3=PTR3+7
 400        CONTINUE
C ... not there - see if we can find it at some other entry point?
C [DO THIS LATER.  FOR NOW, JUST CREATE A NEW ARG BLOCK]
            PTR2=XZYAAB(7)
            SYMATR(PTR+6+I)=PTR2
            ARGPTR=SYMATR(SYMBOL(8,SYMPTR)+I)
            IF (ARGPTR.LT.1) THEN
C "label" dummy arguments don't have symbols attached...
                SYMATR(PTR2+0)=10
                SYMATR(PTR2+3)=3
                GOTO 500
            END IF
            SYMATR(PTR2+0)=SYMBOL(4,ARGPTR)
            SYMATR(PTR2+1)=SYMBOL(5,ARGPTR)
C Store proper character/byte length of dummy argument
            IF (SYMBOL(5,ARGPTR).LT.0) THEN
                SYMATR(PTR2+1)=
     +              ZYXGVA(-SYMBOL(5,ARGPTR))
            ELSE IF (SYMBOL(5,ARGPTR).EQ.0 .AND.
     +               SYMBOL(4,ARGPTR).EQ.6) THEN
                SYMATR(PTR2+1)=1
            END IF
C Argument usage
            IF (ZIAND(SYMBOL(6,ARGPTR),
     +          16+32+64+65536).EQ.0)
     +      THEN
                IF (ZIAND(SYMBOL(6,ARGPTR),131072).EQ.0)
     +          THEN
                    SYMATR(PTR2+2)=1
                ELSE
                    SYMATR(PTR2+2)=0
                END IF
            ELSE
                SYMATR(PTR2+2)=2
            END IF
C Argument structure
            IF (SYMBOL(1,ARGPTR).EQ.7) THEN
                SYMATR(PTR2+3)=2
            ELSE IF (SYMBOL(7,ARGPTR).NE.0) THEN
                SYMATR(PTR2+3)=1
            ELSE
                SYMATR(PTR2+3)=0
            END IF
C Argument size: (only for variables/arrays) (0=inf/adj)
            IF (SYMBOL(1,ARGPTR).EQ.5) THEN
                SYMATR(PTR2+4)=
     +              SYMATR(SYMBOL(8,ARGPTR))
            ELSE
                SYMATR(PTR2+4)=0
            END IF
            SYMATR(PTR2+5)=0
            SYMATR(PTR2+6)=0
 500        CONTINUE
 600    CONTINUE
        ZYXAEN=-2
 
        END
C ----------------------------------------------------------------------
C
C       $ A D D G _ C O M M O N   -   Add global symbol for common block
C
 
        INTEGER FUNCTION ZYXACO(SYMPTR)
        INTEGER SYMPTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
        INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
 
        SAVE /XCSTRI/
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER PUSYM
 
        INTEGER XZYAGC
 
        INTEGER ZYGPUS
        EXTERNAL ZYGPUS
 
        PUSYM=ZYGPUS(SYMBOL(3,SYMPTR))
        ZYXACO=XZYAGC(STRTXT(SYMBOL(2,SYMPTR)),
     +                          SYMBOL(6,SYMPTR),
     +                          MOD(SYMBOL(8,SYMPTR),3),
     +                          SYMBOL(8,SYMPTR)/3,
     +                          PUSYM,
     +                          SYMATR(SYMBOL(7,SYMPTR)))
        IF (ZYXACO.GT.0) THEN
            SYMBOL(8,SYMPTR)=ZYXACO
            ZYXACO=-2
        END IF
 
 
        END
C ----------------------------------------------------------------------
C
C       X $ A D D G _ C O M   -   Add global common symbol
C
 
        INTEGER FUNCTION XZYAGC(NAME,SIZE,TYPE,SAVED,PUSYM,USAGE)
        INTEGER NAME(*),SIZE,TYPE,SAVED,PUSYM,USAGE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        INTEGER APTR,BLANK(8),CDTA,NAMLEN,PUGLOB,NARGS,USE(2)
 
        SAVE BLANK
 
        EQUIVALENCE(APTR,USE(1))
 
        INTEGER EQUAL,LENGTH,LLFIRS,LLNEXT,LLCREL,LLCRHE,LLCRED
        EXTERNAL EQUAL,LENGTH,SCOPY,LLFIRS,LLNEXT,LLCREL,LLCRHE,LLINTO,
     +           LLCRED
 
        DATA BLANK/36,67,79,77,77,79,78,129/
 
C First check that the common block name isn't the same as a p.u. name
        APTR=0
        IF (SYMATR(ATRGLB+0).NE.0)
     +      APTR=LLFIRS(SYMATR,SYMATR(ATRGLB+0))
 100    IF (APTR.NE.0) THEN
            IF (EQUAL(SYMATR(APTR),NAME).EQ.-2) THEN
                XZYAGC=-65
                RETURN
            END IF
            APTR=LLNEXT(SYMATR,APTR)
            GOTO 100
        END IF
 
C Or an entry point name
        IF (SYMATR(ATRGLB+3).NE.0)
     +      APTR=LLFIRS(SYMATR,SYMATR(ATRGLB+0))
 120    IF (APTR.NE.0) THEN
            IF (EQUAL(SYMATR(APTR),NAME).EQ.-2) THEN
                XZYAGC=-65
                RETURN
            END IF
            APTR=LLNEXT(SYMATR,APTR)
            GOTO 120
        END IF
 
C Prepare to record the usage of this common block in the global pu blk
C ... First find the global pu block
        NARGS=SYMBOL(7,PUSYM)
        PUGLOB=SYMATR(SYMBOL(8,PUSYM)+NARGS+1)
C ... Now skip past the name
 150    PUGLOB=PUGLOB+1
        IF (SYMATR(PUGLOB).NE.129) GOTO 150
        PUGLOB=PUGLOB+3
C ... Create the list header if there is none so far
        IF (SYMATR(PUGLOB).EQ.0) SYMATR(PUGLOB)=LLCRHE(SYMATR,0)
C ... Setup the usage data
        USE(2)=USAGE
C ...
        IF (SYMATR(ATRGLB+1).EQ.0)
     +      SYMATR(ATRGLB+1)=LLCRHE(SYMATR,0)
        APTR=LLFIRS(SYMATR,SYMATR(ATRGLB+1))
 200    IF (APTR.NE.0) THEN
            IF (EQUAL(SYMATR(APTR),NAME).EQ.-2) THEN
                XZYAGC=APTR
                CDTA=APTR+LENGTH(SYMATR(APTR))
                IF (SIZE.NE.SYMATR(CDTA+1)) THEN
                    IF (EQUAL(NAME,BLANK).EQ.-3) XZYAGC=-64
                    SYMATR(CDTA+1)=MAX(SYMATR(CDTA+1),SIZE)
                END IF
                IF (TYPE.NE.SYMATR(CDTA+2))
     +              SYMATR(CDTA+2)=2
C If this is not a main program ...
                IF (SAVED.NE.2) THEN
                    IF (SYMATR(CDTA+3).EQ.2) THEN
C Only previous occurrence was a main program - store new SAVE status
                        SYMATR(CDTA+3)=SAVED
C ... Must match previous SAVE status otherwise
                    ELSE IF (SAVED.NE.SYMATR(CDTA+3)) THEN
                        XZYAGC=-63
                    END IF
                END IF
                CALL LLINTO(SYMATR,LLCRED(SYMATR,2,USE),SYMATR(PUGLOB))
                IF (SYMBOL(4,PUSYM).EQ.-2) THEN
                    SYMATR(CDTA+4)=SYMATR(CDTA+4)+1
                    IF (SYMATR(CDTA+4).GT.1)
     +                  XZYAGC=-66
                END IF
                RETURN
            ELSE
                APTR=LLNEXT(SYMATR,APTR)
                GOTO 200
            END IF
        END IF
        NAMLEN=LENGTH(NAME)
        APTR=LLCREL(SYMATR,5+NAMLEN)
        CALL LLINTO(SYMATR,LLCRED(SYMATR,2,USE),SYMATR(PUGLOB))
        CALL LLINTO(SYMATR,APTR,SYMATR(ATRGLB+1))
        CALL SCOPY(NAME,1,SYMATR,APTR)
        CDTA=APTR+NAMLEN
        SYMATR(CDTA+1)=SIZE
        SYMATR(CDTA+2)=TYPE
        SYMATR(CDTA+3)=SAVED
        IF (SYMBOL(4,PUSYM).EQ.-2) THEN
            SYMATR(CDTA+4)=1
        ELSE
            SYMATR(CDTA+4)=0
        END IF
        XZYAGC=APTR
 
        END
C ----------------------------------------------------------------------
C
C       $ A D D G _ P R O C   -   Add global symbol for external proc
C
 
        INTEGER FUNCTION ZYXAPR(SYMPTR)
        INTEGER SYMPTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
        INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
 
        SAVE /XCSTRI/
 
 
        INTEGER NARGS,CHRLEN,LPRPTR,NULL(2),PUSYM,DTYPE
 
        SAVE NULL
 
        INTEGER ZYXGVA,XZYAGP,XZYAP2,XZYAAB
 
        INTEGER ZIAND,ZYGPUS,ZYCADT
        EXTERNAL ZIAND,ZYGPUS,ZYCADT
 
        DATA NULL(1)/129/
 
        PUSYM=ZYGPUS(SYMBOL(3,SYMPTR))
        IF (SYMBOL(4,SYMPTR).EQ.6) THEN
            CHRLEN=SYMBOL(5,SYMPTR)
            IF (CHRLEN.EQ.0) CHRLEN=1
            IF (CHRLEN.LT.0) CHRLEN=ZYXGVA(-CHRLEN)
        ELSE
            DTYPE=ZYCADT(SYMBOL(4,SYMPTR),
     +                   SYMBOL(5,SYMPTR))
            CHRLEN=0
        END IF
        IF (ZIAND(SYMBOL(6,SYMPTR),8192+32768+
     +      2048).EQ.2048) THEN
C First create the lpr record as it hasn't been yet
            SYMBOL(7,SYMPTR)=XZYAAB(2)
            SYMATR(SYMBOL(7,SYMPTR)+1)=-1
            IF (ZIAND(SYMBOL(6,SYMPTR),4).NE.0) THEN
C Indirect routine only passed out as actual parameter
                ZYXAPR=XZYAP2(NULL,
     +                                  -1,
     +                                  DTYPE,
     +                                  CHRLEN,
     +                                  PUSYM,
     +                                  SYMPTR)
            ELSE
C Routine is only passed out as an actual arg - special x$addg call
                ZYXAPR=XZYAP2(STRTXT(SYMBOL(2,SYMPTR)),
     +                                  -1,
     +                                  DTYPE,
     +                                  CHRLEN,
     +                                  PUSYM,
     +                                  SYMPTR)
            END IF
        ELSE IF (SYMBOL(7,SYMPTR).EQ.0) THEN
            ZYXAPR=-62
        ELSE IF (ZIAND(SYMBOL(6,SYMPTR),4).NE.0) THEN
C Indirect Reference
            LPRPTR=SYMBOL(7,SYMPTR)
            NARGS=SYMATR(LPRPTR+1)
            ZYXAPR=XZYAGP(NULL,
     +                             NARGS,
     +                             DTYPE,
     +                             CHRLEN,
     +                             SYMATR(LPRPTR+2),
     +                             PUSYM,
     +                             SYMPTR)
        ELSE
            LPRPTR=SYMBOL(7,SYMPTR)
            NARGS=SYMATR(LPRPTR+1)
            ZYXAPR=XZYAGP(STRTXT(SYMBOL(2,SYMPTR)),
     +                             NARGS,
     +                             DTYPE,
     +                             CHRLEN,
     +                             SYMATR(LPRPTR+2),
     +                             PUSYM,
     +                             SYMPTR)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       X $ A D D G _ P R O C   -   Add global symbol for external proc
C
 
        INTEGER FUNCTION XZYAGP(NAME,NARGS,DTYPE,CHRLEN,ARGBLK,
     +                               PUSYM,SYMPTR)
        INTEGER NAME(*),NARGS,DTYPE,CHRLEN,ARGBLK(*),PUSYM,SYMPTR
 
        INTEGER XZYAP2
        ENTRY XZYAP2(NAME,NARGS,DTYPE,CHRLEN,PUSYM,SYMPTR)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
 
        INTEGER APTR,PUPTR,EPTR,N,NEWTYP,EDATA,NAMLEN,TMP,CBPTR,PUDATA,
     +          I,ARGNUM
 
        INTEGER ZYXCPR,XZYTPC,ZYXCEF
 
        INTEGER EQUAL,LENGTH,LLFIRS,LLNEXT,LLCRHE,LLCREL
        EXTERNAL EQUAL,LENGTH,LLFIRS,LLNEXT,LLCRHE,LLCREL,LLINTO,SCOPY,
     +           ERROR
 
C Step One: For indirect refs, find argument number & skip checks
        IF (NAME(1).EQ.129) THEN
            APTR=SYMBOL(8,PUSYM)
            ARGNUM=1
 100        IF (SYMATR(APTR).NE.SYMPTR) THEN
                APTR=APTR+1
                ARGNUM=ARGNUM+1
                IF (ARGNUM.LE.SYMBOL(7,PUSYM)) GOTO 100
C Not found - try ENTRY points
C Don't have to look backwards from PU symbol to first symbol of p.u.
C because a SUBROUTINE/FUNCTION symbol must ALWAYS precede all entry
C points.
                I=PUSYM+1
 150            IF (I.LE.NSYMS) THEN
                    IF (SYMBOL(3,I).EQ.SYMBOL(3,PUSYM)
     +              )THEN
                        IF (SYMBOL(1,I).EQ.9) THEN
C Found an entry point - check it out.
                            PUSYM=I
                            ARGNUM=1
                            APTR=SYMBOL(8,PUSYM)
                            GOTO 100
                        END IF
                        I=I+1
                        GOTO 150
                    END IF
                END IF
                CALL ERROR('ARG WHICH IS INDIRECT REF NOT FOUND')
            END IF
            GOTO 600
        ELSE
            ARGNUM=0
        END IF
 
C Step Two: Check for a matching program-unit
        PUPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+0))
 200    IF (EQUAL(SYMATR(PUPTR),NAME).EQ.-2) THEN
            SYMATR(SYMBOL(7,SYMPTR)+0)=PUPTR
            PUDATA=PUPTR+LENGTH(SYMATR(PUPTR))
            IF (DTYPE.NE.SYMATR(PUDATA+1) .OR.
     +          SYMATR(PUDATA+2).NE.CHRLEN .AND.
     +          SYMATR(PUDATA+2).GT.0 .AND. CHRLEN.GT.0) THEN
                XZYAGP=-55
            ELSE IF (NARGS.EQ.-1) THEN
                XZYAGP=-2
                CALL XZYAGD(3,ARGNUM,SYMPTR,PUSYM,PUPTR)
            ELSE IF (NARGS.NE.SYMATR(PUDATA+4)) THEN
                XZYAGP=-56
            ELSE
                XZYAGP=
     +            ZYXCPR(SYMATR(PUDATA+7),NARGS,ARGBLK)
                IF (XZYAGP.EQ.-2)
     +              CALL XZYAGD(1,ARGNUM,SYMPTR,PUSYM,
     +                               PUPTR)
            END IF
            RETURN
        ELSE
            PUPTR=LLNEXT(SYMATR,PUPTR)
            IF (PUPTR.NE.0) GOTO 200
        END IF
 
C Step Two-A: Look for a matching ENTRY point.
        IF (SYMATR(ATRGLB+3).NE.0) THEN
            PUPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+3))
 250        IF (EQUAL(SYMATR(PUPTR),NAME).EQ.-2) THEN
                SYMATR(SYMBOL(7,SYMPTR)+0)=PUPTR
                PUDATA=PUPTR+LENGTH(SYMATR(PUPTR))
                IF (DTYPE.NE.SYMATR(PUDATA+1) .OR.
     +              SYMATR(PUDATA+2).NE.CHRLEN .AND.
     +              SYMATR(PUDATA+2).GT.0 .AND. CHRLEN.GT.0)
     +          THEN
                    XZYAGP=-55
                ELSE IF (NARGS.EQ.-1) THEN
                    XZYAGP=-2
                    CALL XZYAGD(3,ARGNUM,SYMPTR,PUSYM,
     +                               PUPTR)
                ELSE IF (NARGS.NE.SYMATR(PUDATA+4)) THEN
                    XZYAGP=-56
                ELSE
                    XZYAGP=ZYXCEF(SYMATR(PUDATA+6),
     +                                         NARGS,ARGBLK)
                    IF (XZYAGP.EQ.-2)
     +                  CALL XZYAGD(1,ARGNUM,SYMPTR,
     +                                   PUSYM,PUPTR)
                END IF
                RETURN
            ELSE
                PUPTR=LLNEXT(SYMATR,PUPTR)
                IF (PUPTR.NE.0) GOTO 250
            END IF
        END IF
 
C Step Three: Check for a matching common block (this is an error!)
        IF (SYMATR(ATRGLB+1).NE.0) THEN
            CBPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+1))
 300        IF (EQUAL(SYMATR(CBPTR),NAME).EQ.-2) THEN
                XZYAGP=-61
                RETURN
            END IF
            CBPTR=LLNEXT(SYMATR,CBPTR)
            IF (CBPTR.NE.0) GOTO 300
        END IF
 
C Step Four: Check for an already existing external reference
        IF (SYMATR(ATRGLB+2).EQ.0)
     +      SYMATR(ATRGLB+2)=LLCRHE(SYMATR,0)
        EPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+2))
        IF (EPTR.GT.0) THEN
 400        IF (EQUAL(SYMATR(EPTR),NAME).EQ.-2) THEN
                SYMATR(SYMBOL(7,SYMPTR)+0)=-EPTR
C Check consistency
                EDATA=EPTR+LENGTH(SYMATR(EPTR))
                IF (DTYPE.NE.SYMATR(EDATA+1)) THEN
                    XZYAGP=-51
                    RETURN
                END IF
                IF (CHRLEN.NE.SYMATR(EDATA+2)) THEN
                    SYMATR(EDATA+2)=0
                END IF
C Check for it only being passed as an actual argument
                IF (NARGS.EQ.-1) THEN
                    XZYAP2=-2
                    CALL XZYAGD(4,ARGNUM,SYMPTR,PUSYM,
     +                               EPTR)
                    RETURN
                END IF
                IF (NARGS.NE.SYMATR(EDATA+3)) THEN
                    XZYAGP=-52
                    RETURN
                END IF
                EDATA=EDATA+4
                APTR=1
                TMP=NARGS
 500            IF (TMP.GT.0) THEN
                    NEWTYP=XZYTPC(MOD(ARGBLK(APTR+0),8),
     +                                 MOD(SYMATR(EDATA+0),8))
                    IF (NEWTYP.EQ.-1) THEN
                        XZYAGP=-53
                        RETURN
                    END IF
                    SYMATR(EDATA+0)=
     +                  (SYMATR(EDATA+0)/8)*8+NEWTYP
C Arguments must match in type (page 15-8, section 15.5.2.2) with
C the FUNCTION/SUBROUTINE declaration - they obviously cannot if they
C are of differing types in different references!
                    IF (ARGBLK(APTR+0)/8.NE.
     +                  SYMATR(EDATA+0)/8) THEN
                        XZYAGP=-54
                        RETURN
                    END IF
                    IF (SYMATR(EDATA+0)/8+(-3).EQ.
     +                  6) THEN
                        SYMATR(EDATA+2)=
     +                      MIN(SYMATR(EDATA+2),
     +                          ARGBLK(APTR+2))
                        SYMATR(EDATA+3)=
     +                      MAX(SYMATR(EDATA+3),
     +                          ARGBLK(APTR+3))
                        EDATA=EDATA+4
                        APTR=APTR+4
                    ELSE
                        EDATA=EDATA+2
                        APTR=APTR+2
                    END IF
                    TMP=TMP-1
                    GOTO 500
                END IF
                XZYAGP=-2
                CALL XZYAGD(2,ARGNUM,SYMPTR,PUSYM,EPTR)
                RETURN
            ELSE
                EPTR=LLNEXT(SYMATR,EPTR)
                IF (EPTR.NE.0) GOTO 400
            END IF
        END IF
 
C Step 5: Add the new reference to the database
C (but not if only passed out as an actual argument)
 600    IF (NARGS.EQ.-1) THEN
            IF (NAME(1).EQ.129) THEN
                CALL XZYAGD(6,ARGNUM,SYMPTR,PUSYM,EPTR)
            ELSE
                CALL XZYAGD(7,ARGNUM,SYMPTR,PUSYM,EPTR)
            END IF
            XZYAP2=-2
            RETURN
        END IF
 
C Make sure we have a header record
        IF (SYMATR(ATRGLB+2).EQ.0)
     +      SYMATR(ATRGLB+2)=LLCRHE(SYMATR,0)
C Work out how long current proc block is
        N=1
        TMP=NARGS
 700    IF (TMP.GT.0) THEN
            IF (ARGBLK(N+0)/8+(-3).EQ.6) THEN
                N=N+4
            ELSE
                N=N+2
            END IF
            TMP=TMP-1
            GOTO 700
        END IF
        N=N-1
 
C And add it
        NAMLEN=LENGTH(NAME)
        EPTR=LLCREL(SYMATR,NAMLEN+4+N)
        IF (NAME(1).EQ.129) THEN
            CALL XZYAGD(5,ARGNUM,SYMPTR,PUSYM,EPTR)
        ELSE IF (NARGS.GE.0) THEN
            CALL XZYAGD(2,ARGNUM,SYMPTR,PUSYM,EPTR)
        ELSE
            CALL XZYAGD(4,ARGNUM,SYMPTR,PUSYM,EPTR)
        END IF
        CALL LLINTO(SYMATR,EPTR,SYMATR(ATRGLB+2))
        CALL SCOPY(NAME,1,SYMATR,EPTR)
        SYMATR(SYMBOL(7,SYMPTR)+0)=-EPTR
        EPTR=EPTR+NAMLEN
        SYMATR(EPTR+1)=DTYPE
        SYMATR(EPTR+2)=CHRLEN
        SYMATR(EPTR+3)=NARGS
        EPTR=EPTR+4
        N=1
        DO 800 I=1,NARGS
            SYMATR(EPTR+0)=ARGBLK(N+0)
            SYMATR(EPTR+1)=0
            IF (ARGBLK(N+0)/8+(-3).EQ.6) THEN
                SYMATR(EPTR+2)=ARGBLK(N+2)
                SYMATR(EPTR+3)=ARGBLK(N+3)
                EPTR=EPTR+4
                N=N+4
            ELSE
                EPTR=EPTR+2
                N=N+2
            END IF
 800    CONTINUE
        XZYAGP=-2
 
        END
C ----------------------------------------------------------------------
C
C       X $ A D D G _ D E S C   -   Add descendant routine to global pu
C
C       This adds the routine as a descendent both to the program-unit
C       and to any dummy arguments which are passed down to it.
C
 
        SUBROUTINE XZYAGD(TYPE,NUMBER,SYMPTR,PUSYM,GSYPTR)
        INTEGER TYPE,NUMBER,SYMPTR,PUSYM,GSYPTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCPAHP/USHEAD,PAHEAD,PAHEAP
        INTEGER USHEAD,PAHEAD,PAHEAP(11000)
 
        SAVE /XCPAHP/
 
        INTEGER DESCND(6),PUGLOB,DESREC,NARGS,P,LPRD,P1,P2,ARGNUM,N
 
        INTEGER LLCRED,LLCRHE,LLFIRS,LLNEXT
        EXTERNAL LLINTO,LLCRED,LLCRHE,LLFIRS,LLNEXT,ERROR
 
C First add it to the program-unit as a whole.
C Prepare program-unit's descendant list
        PUGLOB=SYMATR(SYMBOL(8,PUSYM)+SYMBOL(7,PUSYM)+1)
 100    IF (SYMATR(PUGLOB).NE.129) THEN
            PUGLOB=PUGLOB+1
            GOTO 100
        END IF
        IF (SYMBOL(1,PUSYM).EQ.4) THEN
            PUGLOB=PUGLOB+5
        ELSE
            PUGLOB=PUGLOB+5
        END IF
        IF (TYPE.NE.7) THEN
            IF (SYMATR(PUGLOB).EQ.0) SYMATR(PUGLOB)=LLCRHE(SYMATR,0)
            DESCND(1)=TYPE
            DESCND(2)=GSYPTR
            DESCND(3)=NUMBER
            DESREC=LLCRED(SYMATR,3,DESCND)
            CALL LLINTO(SYMATR,DESREC,SYMATR(PUGLOB))
        END IF
 
C Now check for any dummy arguments passed down.
        IF (SYMBOL(7,SYMPTR).EQ.0)
     +      CALL ERROR('XZYAGD: NO LPR RECORD FOUND')
        NARGS=SYMATR(SYMBOL(7,SYMPTR)+1)
        IF (NARGS.LE.0) RETURN
        P=SYMBOL(7,SYMPTR)+2
        ARGNUM=1
        IF (SYMBOL(1,PUSYM).EQ.4) THEN
            PUGLOB=PUGLOB+7-5
        ELSE
            PUGLOB=PUGLOB+6-5
        END IF
 200    IF (SYMATR(P+1).NE.0) THEN
C Found a descendent list - process it
            LPRD=LLFIRS(SYMATR,SYMATR(P+1))
 300        IF (SYMATR(LPRD).EQ.6) THEN
C ... dummy argument passed down
                P1=SYMBOL(8,PUSYM)
                P2=PUGLOB
                N=SYMBOL(7,PUSYM)
 400            IF (SYMATR(P1).NE.SYMATR(LPRD+1)) THEN
                    IF (SYMBOL(1,PUSYM).EQ.4) THEN
                        P2=P2+7
                    ELSE
                        P2=P2+1
                    END IF
                    P1=P1+1
                    N=N-1
                    IF (N.GT.0) GOTO 400
C If not found then do absolutely nothing (must be an ENTRY argument)
                ELSE
C Found the matching argument - add to its passage list
                    IF (SYMBOL(1,PUSYM).EQ.4) THEN
                        P2=P2+5
                    ELSE
                        P2=SYMATR(P2)+5
                    END IF
                    IF (SYMATR(P2).EQ.0)
     +                  SYMATR(P2)=LLCRHE(SYMATR,0)
                    DESCND(1)=ARGNUM
                    DESCND(2)=DESREC
                    CALL LLINTO(SYMATR,LLCRED(SYMATR,2,DESCND),
     +                                 SYMATR(P2))
                END IF
            ELSE IF (SYMATR(LPRD).EQ.0) THEN
C ... Direct procedure passed down
                DESCND(1+0)=ARGNUM
                DESCND(1+1)=SYMPTR
                DESCND(1+2)=SYMATR(LPRD+1)
                DESCND(1+3)=PUSYM
                DESCND(1+4)=SYMATR(LPRD+2)
                CALL LLINTO(PAHEAP,LLCRED(PAHEAP,5,DESCND),PAHEAD)
            ELSE
C ... Possibly unsafe ref - store in PAHEAP for later
                DESCND(1+1)=ARGNUM
                DESCND(1+3)=PUSYM
                DESCND(1+0)=SYMATR(LPRD)
                DESCND(1+4)=SYMATR(LPRD+2)
                DESCND(1+2)=SYMATR(LPRD+1)
                DESCND(1+5)=SYMPTR
                CALL LLINTO(PAHEAP,LLCRED(PAHEAP,6,DESCND),
     +                      USHEAD)
            END IF
C Process next item on descendent list
            LPRD=LLNEXT(SYMATR,LPRD)
            IF (LPRD.NE.0) GOTO 300
        END IF
        IF (SYMATR(P+0)/8+(-3).EQ.6) THEN
            P=P+4
        ELSE
            P=P+2
        END IF
        ARGNUM=ARGNUM+1
        IF (ARGNUM.LE.NARGS) GOTO 200
 
        END
C ----------------------------------------------------------------------
C
C       $ C H E C K _ P R O C   -   Check proc/pu consistency
C
 
        INTEGER FUNCTION ZYXCPR(PU,NPRARG,PRARGS)
        INTEGER PU(*),NPRARG,PRARGS(*)
 
        INTEGER P1,P2,N
 
        INTEGER XZYCKA
 
        N=NPRARG
        P1=1
        P2=1
        ZYXCPR=-2
        IF (N.GT.0) THEN
100         ZYXCPR=XZYCKA(PU(P1),PRARGS(P2))
            IF (ZYXCPR.NE.-2) RETURN
            IF (PU(P1+0).EQ.6) THEN
                P2=P2+4
            ELSE
                P2=P2+2
            END IF
            P1=P1+7
            N=N-1
            IF (N.GT.0) GOTO 100
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       $ C H K _ E N T R Y _ R E F   -   Check entry/proc consistency
C
 
        INTEGER FUNCTION ZYXCEF(EARGS,NARGS,PRARGS)
        INTEGER EARGS(*),NARGS,PRARGS(*)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER P1,P2
 
        INTEGER XZYCKA
 
        P1=1
        P2=1
        ZYXCEF=-2
        IF (NARGS.GT.0) THEN
100         ZYXCEF=XZYCKA(SYMATR(EARGS(P1)),PRARGS(P2))
            IF (ZYXCEF.NE.-2) RETURN
            IF (SYMATR(EARGS(P1)+0).EQ.6) THEN
                P2=P2+4
            ELSE
                P2=P2+2
            END IF
            P1=P1+1
            IF (P1.LE.NARGS) GOTO 100
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       X $ C H E C K _ A R G   -   Check GPU/LPR argument compatibility
C
 
        INTEGER FUNCTION XZYCKA(GPUARG,LPRARG)
        INTEGER GPUARG(0:7-1),LPRARG(0:*)
 
        LOGICAL ZYXCAS
 
C Arg: Must have the same type
        IF (GPUARG(0).NE.
     +      LPRARG(0)/8+(-3)) THEN
            XZYCKA=-57
C Arg: If fixed-length char, must be at least as long
        ELSE IF (GPUARG(0).EQ.6 .AND.
     +           LPRARG(2).NE.0 .AND.
     +           LPRARG(2).LT.GPUARG(1)) THEN
            XZYCKA=-60
C Arg: Must match structure (array/proc/label/scalar)
        ELSE IF (.NOT.ZYXCAS(GPUARG(3),
     +                             MOD(LPRARG(0),8))) THEN
            XZYCKA=-59
        ELSE
            XZYCKA=-2
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       $ A D D G _ P A S S   -   Add global argument passage records
C
 
        SUBROUTINE ZYXAAP
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCPAHP/USHEAD,PAHEAD,PAHEAP
        INTEGER USHEAD,PAHEAD,PAHEAP(11000)
 
        SAVE /XCPAHP/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
        INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
 
        SAVE /XCSTRI/
 
 
        INTEGER PAREC,ARGSYM,GPRSYM,GASYM,P,GP,INHREC(4),I,
     +          CHRLEN,STATUS
 
        INTEGER ZYXGVA,XZYAP2
 
        INTEGER LLFIRS,LLNEXT,LLCRHE,LLCRED,LLHEAD
        EXTERNAL LLFIRS,LLNEXT,LLCRHE,LLCRED,LLHEAD,LLINTO,ERROR
 
        PAREC=LLFIRS(PAHEAP,PAHEAD)
        IF (PAREC.NE.0) THEN
 100        ARGSYM=PAHEAP(PAREC+2)
            GASYM=SYMATR(SYMBOL(7,ARGSYM)+0)
            IF (GASYM.EQ.0) THEN
C The routine being passed down has never been called directly and does
C not occur in this file - so we must create a special g_ext record
                CHRLEN=SYMBOL(5,ARGSYM)
                IF (CHRLEN.LT.0) THEN
                    CHRLEN=ZYXGVA(-CHRLEN)
                ELSE IF (SYMBOL(4,ARGSYM).EQ.6 .AND.
     +                   CHRLEN.EQ.0) THEN
                    CHRLEN=1
                END IF
                STATUS=XZYAP2(STRTXT(SYMBOL(2,ARGSYM)),
     +                              -2,
     +                              SYMBOL(4,ARGSYM),
     +                              CHRLEN,
     +                              PAHEAP(PAREC+3),
     +                              ARGSYM)
                IF (STATUS.NE.-2) CALL ERROR('ZYXAAP: FAILED')
                GASYM=SYMATR(SYMBOL(7,ARGSYM)+0)
            END IF
            GPRSYM=SYMATR(
     +          SYMBOL(7,PAHEAP(PAREC+1))+0)
            GP=ABS(GPRSYM)
 200        IF (SYMATR(GP).NE.129) THEN
                GP=GP+1
                GOTO 200
            END IF
            IF (GPRSYM.GT.0) THEN
C Passed down to a satisfied reference - we have a global pu record
C or perhaps a global entry record
                IF (LLHEAD(SYMATR,GPRSYM).EQ.SYMATR(ATRGLB+0))
     +          THEN
                    P=GP+7+
     +                (PAHEAP(PAREC+0)-1)*7+
     +                6
                ELSE
                    P=GP+6+(PAHEAP(PAREC+0)-1)
                    P=SYMATR(P)+6
                END IF
            ELSE IF (GPRSYM.LT.0) THEN
C Passed down to an unsatisfied reference - make do with a g_ext record
                P=GP+4
                DO 300 I=2,PAHEAP(PAREC+0)
                    IF (SYMATR(P+0)/8+(-3).EQ.6)
     +              THEN
                        P=P+4
                    ELSE
                        P=P+2
                    END IF
 300            CONTINUE
                P=P+1
            END IF
            IF (SYMATR(P).EQ.0) SYMATR(P)=LLCRHE(SYMATR,0)
            INHREC(1+0)=0
            INHREC(1+3)=GASYM
C Turn S_PU symbol pointer into global pu record pointer
            INHREC(1+1)=SYMATR(
     +          SYMBOL(8,PAHEAP(PAREC+3))+
     +          SYMBOL(7,PAHEAP(PAREC+3))+1)
            INHREC(1+2)=PAHEAP(PAREC+4)
            CALL LLINTO(SYMATR,LLCRED(SYMATR,4,INHREC),
     +                         SYMATR(P))
            PAREC=LLNEXT(PAHEAP,PAREC)
            IF (PAREC.GT.0) GOTO 100
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       $ A D D G _ U N S A F E   -   Adds global unsafe ref check rcds
C
 
        SUBROUTINE ZYXAUS
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
        INTEGER NSYMS,NPUS,PUIDX(250),
     +          SYMBOL(8,5003)
        LOGICAL MODFLG
 
        SAVE /XCSYMS/
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCPAHP/USHEAD,PAHEAD,PAHEAP
        INTEGER USHEAD,PAHEAD,PAHEAP(11000)
 
        SAVE /XCPAHP/
 
        INTEGER MTYPE1
        PARAMETER (MTYPE1=5)
 
        INTEGER USREF,GPRSYM,GP,P,I,INHREC(4),PX,COUNT
        LOGICAL ADDIT
 
        INTEGER LLFIRS,LLNEXT,LLCRHE,LLCRED,LLHEAD
        EXTERNAL LLFIRS,LLNEXT,LLCRHE,LLCRED,LLHEAD,LLINTO
 
        USREF=LLFIRS(PAHEAP,USHEAD)
        IF (USREF.NE.0) THEN
 100        GPRSYM=SYMATR(SYMBOL(7,
     +                           PAHEAP(USREF+5))+0)
            GP=ABS(GPRSYM)
 200        IF (SYMATR(GP).NE.129) THEN
                GP=GP+1
                GOTO 200
            END IF
            IF (GPRSYM.GT.0) THEN
                IF (LLHEAD(SYMATR,GPRSYM).EQ.SYMATR(ATRGLB+0))
     +          THEN
                    P=GP+7+
     +                (PAHEAP(USREF+1)-1)*7+
     +                6
                ELSE
                    P=GP+6+(PAHEAP(USREF+1)-1)
                    P=SYMATR(P)+6
                END IF
            ELSE
                P=GP+4
                DO 300 I=2,PAHEAP(USREF+1)
                    IF (SYMATR(P)/8+(-3).EQ.6) THEN
                        P=P+4
                    ELSE
                        P=P+2
                    END IF
 300            CONTINUE
                P=P+1
            END IF
            IF (SYMATR(P).EQ.0) SYMATR(P)=LLCRHE(SYMATR,0)
            INHREC(1+0)=PAHEAP(USREF+0)
            INHREC(1+1)=SYMATR(
     +          SYMBOL(8,PAHEAP(USREF+3))+
     +          SYMBOL(7,PAHEAP(USREF+3))+1)
            INHREC(1+2)=PAHEAP(USREF+4)
            IF (PAHEAP(USREF+0).EQ.3) THEN
                INHREC(1+3)=
     +              SYMBOL(8,PAHEAP(USREF+2))
            ELSE
                INHREC(1+3)=PAHEAP(USREF+2)
            END IF
C Only add "inherit-expression" record if there is less than MTYPE1 of
C them already.
            IF (INHREC(1+0).EQ.1) THEN
                PX=LLFIRS(SYMATR,SYMATR(P))
                COUNT=0
                IF (PX.NE.0) THEN
 400                IF (SYMATR(PX+0).EQ.1)
     +                  COUNT=COUNT+1
                    PX=LLNEXT(SYMATR,PX)
                    IF (PX.NE.0) GOTO 400
                END IF
                ADDIT=COUNT.LT.MTYPE1
            ELSE
                ADDIT=.TRUE.
            END IF
            IF (ADDIT)
     +          CALL LLINTO(SYMATR,LLCRED(SYMATR,4,INHREC),
     +                  SYMATR(P))
            USREF=LLNEXT(PAHEAP,USREF)
            IF (USREF.NE.0) GOTO 100
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T G _ P U   -   Get a global program-unit attribute block
C
 
        SUBROUTINE ZYXGPU(GPUPTR,NAME,DTYPE,CHRLEN,NARGS,CULIST,DESC,
     +                      ELIST,ARG)
        INTEGER GPUPTR,NAME(*),DTYPE,CHRLEN,NARGS,CULIST,DESC,ELIST,
     +          ARG(0:7-1,*)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER I,J,CURDTA
 
        INTEGER LENGTH,LLFIRS,LLNEXT
        EXTERNAL LENGTH,LLFIRS,LLNEXT,SCOPY,ERROR
 
        IF (GPUPTR.EQ.-1) THEN
            IF (SYMATR(ATRGLB+0).EQ.0)
     +          CALL ERROR('No global attributes found')
            GPUPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+0))
        ELSE IF (GPUPTR.EQ.0) THEN
            CALL ERROR('ZYXGPU: NIL POINTER SUPPLIED')
        END IF
        CALL SCOPY(SYMATR,GPUPTR,NAME,1)
        CURDTA=GPUPTR+LENGTH(NAME)
        DTYPE=SYMATR(CURDTA+1)
        CHRLEN=SYMATR(CURDTA+2)
        CULIST=SYMATR(CURDTA+3)
        IF (CULIST.NE.0) CULIST=LLFIRS(SYMATR,CULIST)
        NARGS=SYMATR(CURDTA+4)
        DESC=SYMATR(CURDTA+5)
        IF (DESC.NE.0) DESC=LLFIRS(SYMATR,DESC)
        ELIST=SYMATR(CURDTA+6)
        IF (ELIST.NE.0) ELIST=LLFIRS(SYMATR,ELIST)
        CURDTA=CURDTA+7
        DO 200 I=1,NARGS
            DO 100 J=0,4
                ARG(J,I)=SYMATR(CURDTA+J)
 100        CONTINUE
            IF (SYMATR(CURDTA+5).NE.0) THEN
                ARG(5,I)=LLFIRS(SYMATR,SYMATR(CURDTA+5))
            ELSE
                ARG(5,I)=0
            END IF
            IF (SYMATR(CURDTA+6).NE.0) THEN
                ARG(6,I)=LLFIRS(SYMATR,SYMATR(CURDTA+6))
            ELSE
                ARG(6,I)=0
            END IF
            CURDTA=CURDTA+7
 200    CONTINUE
        GPUPTR=LLNEXT(SYMATR,GPUPTR)
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T G _ P A S S   -   Get a passage record for a p.u. arg
C
 
        SUBROUTINE ZYXGPA(PASSX,ARGNUM,DESREC)
        INTEGER PASSX,ARGNUM,DESREC
 
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER LLNEXT
        EXTERNAL ERROR,LLNEXT
 
        IF (PASSX.LE.0) CALL ERROR('ZYXGPA: Invalid Argument')
        ARGNUM=SYMATR(PASSX)
        DESREC=SYMATR(PASSX+1)
        PASSX=LLNEXT(SYMATR,PASSX)
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T G _ C U D A T A   -   Get common usage list entry data
C
 
        SUBROUTINE ZYXGCU(CULIST,GCBPTR,USAGE)
        INTEGER CULIST,GCBPTR,USAGE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER LLNEXT
        EXTERNAL LLNEXT
 
        GCBPTR=SYMATR(CULIST)
        USAGE=SYMATR(CULIST+1)
        CULIST=LLNEXT(SYMATR,CULIST)
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T G _ D E S C   -   Get program-unit descendant data
C
 
        SUBROUTINE ZYXGGD(DESC,REFTYP,GSYPTR,ARGNUM)
        INTEGER DESC,REFTYP,GSYPTR,ARGNUM
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER LLNEXT
        EXTERNAL LLNEXT
 
        REFTYP=SYMATR(DESC)
        GSYPTR=SYMATR(DESC+1)
        ARGNUM=SYMATR(DESC+2)
        DESC=LLNEXT(SYMATR,DESC)
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T G _ E N T _ P T R   -   Get global ENTRY point pointer
C
 
        SUBROUTINE ZYXGEP(ELIST,ENTPTR)
        INTEGER ELIST,ENTPTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER LLNEXT
        EXTERNAL LLNEXT
 
        ENTPTR=SYMATR(ELIST)
        ELIST=LLNEXT(SYMATR,ELIST)
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T G _ E N T R Y   -   Get a global ENTRY point record
C
 
        SUBROUTINE ZYXGEN(GENPTR,NAME,DTYPE,CHRLEN,NARGS,GPU,DESC,
     +                         ARG)
        INTEGER GENPTR,NAME(*),DTYPE,CHRLEN,NARGS,GPU,DESC,
     +          ARG(0:7-1,*)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER I,J,CURDTA,ARGX
 
        INTEGER LENGTH,LLFIRS,LLNEXT
        EXTERNAL LENGTH,LLFIRS,LLNEXT,ERROR,SCOPY
 
        IF (GENPTR.EQ.-1) THEN
            IF (SYMATR(ATRGLB+3).EQ.0) RETURN
            GENPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+3))
        ELSE IF (GENPTR.EQ.0) THEN
            CALL ERROR('ZYXGEN: NIL POINTER SUPPLIED')
        END IF
        CALL SCOPY(SYMATR,GENPTR,NAME,1)
        CURDTA=GENPTR+LENGTH(NAME)
        DTYPE=SYMATR(CURDTA+1)
        CHRLEN=SYMATR(CURDTA+2)
        NARGS=SYMATR(CURDTA+4)
        GPU=SYMATR(CURDTA+3)
        DESC=SYMATR(CURDTA+5)
        IF (DESC.NE.0) DESC=LLFIRS(SYMATR,DESC)
        CURDTA=CURDTA+6
        DO 200 I=1,NARGS
            ARGX=SYMATR(CURDTA+I-1)
            DO 100 J=0,4
                ARG(J,I)=SYMATR(ARGX+J)
 100        CONTINUE
            IF (SYMATR(ARGX+5).NE.0) THEN
                ARG(5,I)=LLFIRS(SYMATR,SYMATR(ARGX+5))
            ELSE
                ARG(5,I)=0
            END IF
            IF (SYMATR(ARGX+6).NE.0) THEN
                ARG(6,I)=LLFIRS(SYMATR,SYMATR(ARGX+6))
            ELSE
                ARG(6,I)=0
            END IF
 200    CONTINUE
        GENPTR=LLNEXT(SYMATR,GENPTR)
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T G _ C O M   -   Get a global common block attr block
C
 
        SUBROUTINE ZYXGCB(GCBPTR,NAME,COMLEN,COMTYP,COMSAV,
     +                             COMINI)
        INTEGER GCBPTR,NAME(*),COMLEN,COMTYP,COMSAV,COMINI
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER CURDTA
 
        INTEGER LENGTH,LLFIRS,LLNEXT
        EXTERNAL LENGTH,LLFIRS,LLNEXT,SCOPY,ERROR
 
        IF (GCBPTR.EQ.-1) THEN
            IF (SYMATR(ATRGLB+1).EQ.0) RETURN
            GCBPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+1))
        ELSE IF (GCBPTR.EQ.0) THEN
            CALL ERROR('ZYXGCB: NIL POINTER SUPPLIED')
        END IF
        CALL SCOPY(SYMATR,GCBPTR,NAME,1)
        CURDTA=GCBPTR+LENGTH(NAME)
        COMLEN=SYMATR(CURDTA+1)
        COMTYP=SYMATR(CURDTA+2)
        COMSAV=SYMATR(CURDTA+3)
        COMINI=SYMATR(CURDTA+4)
        GCBPTR=LLNEXT(SYMATR,GCBPTR)
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T G _ E X T   -   Get a global external reference atr blk
C
 
        SUBROUTINE ZYXGEX(GEXPTR,NAME,DTYPE,CHRLEN,NARGS,ARGBLK)
        INTEGER GEXPTR,NAME(*),DTYPE,CHRLEN,NARGS,ARGBLK(*)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER I,J,CURDTA
 
        INTEGER LENGTH,LLFIRS,LLNEXT
        EXTERNAL LENGTH,LLFIRS,LLNEXT,ERROR,SCOPY
 
        IF (GEXPTR.EQ.-1) THEN
            IF (SYMATR(ATRGLB+2).EQ.0) RETURN
            GEXPTR=LLFIRS(SYMATR,SYMATR(ATRGLB+2))
        ELSE IF (GEXPTR.EQ.0) THEN
            CALL ERROR('ZYXGEX: NIL POINTER SUPPLIED')
        END IF
        CALL SCOPY(SYMATR,GEXPTR,NAME,1)
        CURDTA=GEXPTR+LENGTH(NAME)
        DTYPE=SYMATR(CURDTA+1)
        CHRLEN=SYMATR(CURDTA+2)
        NARGS=SYMATR(CURDTA+3)
        CURDTA=CURDTA+4-1
        J=1
        DO 100 I=1,NARGS
            ARGBLK(J+0)=SYMATR(CURDTA+J+0)
            ARGBLK(J+1)=SYMATR(CURDTA+J+1)
            IF (ARGBLK(J+1).NE.0)
     +          ARGBLK(J+1)=LLFIRS(SYMATR,ARGBLK(J+1))
            IF (ARGBLK(J+0)/8+(-3).EQ.6) THEN
                ARGBLK(J+2)=SYMATR(CURDTA+J+2)
                ARGBLK(J+3)=SYMATR(CURDTA+J+3)
                J=J+4
            ELSE
                J=J+2
            END IF
 100    CONTINUE
        GEXPTR=LLNEXT(SYMATR,GEXPTR)
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T G _ N A M E   -   Get global name
C
 
        SUBROUTINE ZYXGNA(NAMPTR,NAME)
        INTEGER NAMPTR,NAME(*)
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        EXTERNAL SCOPY
 
        CALL SCOPY(SYMATR,NAMPTR,NAME,1)
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T G _ I D X _ P U   -   Get global program-unit index
C
C       Negative results are minus entry point index values.
C
 
        INTEGER FUNCTION ZYXGIP(GPUPTR)
        INTEGER GPUPTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER PTR
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT,ERROR
 
        ZYXGIP=1
        PTR=LLFIRS(SYMATR,SYMATR(ATRGLB+0))
 100    IF (PTR.EQ.GPUPTR) RETURN
        PTR=LLNEXT(SYMATR,PTR)
        ZYXGIP=ZYXGIP+1
        IF (PTR.NE.0) GOTO 100
C Didn't find it there - try the ENTRY point list
        ZYXGIP=-1
        PTR=LLFIRS(SYMATR,SYMATR(ATRGLB+3))
 200    IF (PTR.EQ.GPUPTR) RETURN
        PTR=LLNEXT(SYMATR,PTR)
        ZYXGIP=ZYXGIP-1
        IF (PTR.NE.0) GOTO 200
        CALL ERROR('ZYXGIP: Couldn''t find program unit')
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T G _ I D X _ C B   -   Get global common-block index
C
 
        INTEGER FUNCTION ZYXGIC(GCBPTR)
        INTEGER GCBPTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER PTR
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT,ERROR
 
        ZYXGIC=1
        PTR=LLFIRS(SYMATR,SYMATR(ATRGLB+1))
 100    IF (PTR.EQ.GCBPTR) RETURN
        PTR=LLNEXT(SYMATR,PTR)
        ZYXGIC=ZYXGIC+1
        IF (PTR.NE.0) GOTO 100
        CALL ERROR('ZYXGIC: Couldn''t find common block')
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T G _ I D X _ E X   -   Get global external ref index
C
 
        INTEGER FUNCTION ZYXGIE(GEXPTR)
        INTEGER GEXPTR
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER PTR
 
        INTEGER LLFIRS,LLNEXT
        EXTERNAL LLFIRS,LLNEXT,ERROR
 
        ZYXGIE=1
        PTR=LLFIRS(SYMATR,SYMATR(ATRGLB+2))
 100    IF (PTR.EQ.GEXPTR) RETURN
        PTR=LLNEXT(SYMATR,PTR)
        ZYXGIE=ZYXGIE+1
        IF (PTR.NE.0) GOTO 100
        CALL ERROR('ZYXGIE: Couldn''t find external ref')
 
        END
C ----------------------------------------------------------------------
C
C       $ G E T G _ I N H R E C   -   Get global argument inheritance
C
 
        SUBROUTINE ZYXGIR(INHREC,INHTYP,ASSOC,STMTNO,EXTRA)
        INTEGER INHREC,INHTYP,ASSOC,STMTNO,EXTRA
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER LLNEXT
        EXTERNAL ERROR,LLNEXT
 
        IF (INHREC.LE.0) CALL ERROR('ZYXGIR: Invalid argument')
        INHTYP=SYMATR(INHREC+0)
        ASSOC=SYMATR(INHREC+1)
        STMTNO=SYMATR(INHREC+2)
        EXTRA=SYMATR(INHREC+3)
        INHREC=LLNEXT(SYMATR,INHREC)
 
        END
C ----------------------------------------------------------------------
C
C       X $ P R O C _ T Y P C   -   Procedure type compatibility
C
 
        INTEGER FUNCTION XZYTPC(TYP1,TYP2)
        INTEGER TYP1,TYP2
 
        INTEGER COMTYP(0:4,0:4)
 
        SAVE COMTYP
 
C COMTYP(newtype,oldtype)=actual type or -1 for invalid combinations
 
        DATA COMTYP/ 0, 0,-1,-1,-1,
     +               0, 1, 2,-1,-1,
     +              -1, 2, 2,-1,-1,
     +              -1,-1,-1, 3,-1,
     +              -1,-1,-1,-1, 4/
 
        XZYTPC=COMTYP(TYP1,TYP2)
 
        END
C ----------------------------------------------------------------------
C
C       X $ A L L O C _ A T R   -   (Internal) allocate an attribute blk
C
 
        INTEGER FUNCTION XZYAAB(SIZE)
        INTEGER SIZE
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.5
C---------------------------------------------------------
        COMMON/XCATRX/SYMATR,ATRGLB
        INTEGER SYMATR(69000),ATRGLB
        SAVE /XCATRX/
 
        INTEGER I
 
        INTEGER HGET1,HALLOC
        EXTERNAL HGET1,HALLOC
 
        IF (SIZE.EQ.1) THEN
            XZYAAB=HGET1(SYMATR)
        ELSE
            XZYAAB=HALLOC(SYMATR,SIZE)
        END IF
        DO 100 I=XZYAAB,XZYAAB+SIZE-1
            SYMATR(I)=0
 100    CONTINUE
 
        END
C ----------------------------------------------------------------------
C
C       $ C H K _ A S T R U C T   -   Check argument structure
C
 
        LOGICAL FUNCTION ZYXCAS(STRUCT,ATYPE)
        INTEGER STRUCT,ATYPE
 
C Arg: If proc, must match proc
        IF (STRUCT.EQ.2 .NEQV. ATYPE.EQ.3 .OR.
C Arg: array must match array/arelm
     +      STRUCT.EQ.1 .AND. ATYPE.NE.1 .AND.
     +                                   ATYPE.NE.2 .OR.
     +      STRUCT.NE.1 .AND. ATYPE.EQ.2) THEN
            ZYXCAS=.FALSE.
        ELSE
            ZYXCAS=.TRUE.
        END IF
 
        END
